From ffa55b29a282ff248bf4869bd96d7b0366d71aae Mon Sep 17 00:00:00 2001 From: Chad Granum Date: Tue, 28 Nov 2023 16:25:18 -0800 Subject: [PATCH] FIXME - TODO, temp stuff, garbage, old tests, references, etc This commit should never go out, it has a random assortment of notes and temporary stuff. --- .perlcriticrc | 13 + .yath.rc => .yath.rc.xxx | 0 Debug.pm | 339 ++++ Workspace.pm | 64 + bad/App/Yath.pm | 879 ++++++++++ bad/App/Yath/Command.pm | 383 +++++ bad/App/Yath/Command/abort.pm | 68 + {lib => bad}/App/Yath/Command/auditor.pm | 0 bad/App/Yath/Command/collector.pm | 69 + {lib => bad}/App/Yath/Command/do.pm | 0 {lib => bad}/App/Yath/Command/failed.pm | 0 bad/App/Yath/Command/help.pm | 96 ++ {lib => bad}/App/Yath/Command/init.pm | 0 {lib => bad}/App/Yath/Command/kill.pm | 0 {lib => bad}/App/Yath/Command/projects.pm | 0 {lib => bad}/App/Yath/Command/ps.pm | 1 - {lib => bad}/App/Yath/Command/reload.pm | 0 {lib => bad}/App/Yath/Command/replay.pm | 0 bad/App/Yath/Command/resources.pm | 159 ++ bad/App/Yath/Command/run.pm | 232 +++ bad/App/Yath/Command/runner.pm | 519 ++++++ {lib => bad}/App/Yath/Command/spawn.pm | 0 {lib => bad}/App/Yath/Command/speedtag.pm | 0 bad/App/Yath/Command/start.pm | 207 +++ {lib => bad}/App/Yath/Command/status.pm | 1 - {lib => bad}/App/Yath/Command/stop.pm | 1 - bad/App/Yath/Command/test.pm | 865 ++++++++++ {lib => bad}/App/Yath/Command/times.pm | 0 bad/App/Yath/Command/watch.pm | 100 ++ {lib => bad}/App/Yath/Command/which.pm | 0 {lib => bad}/App/Yath/Converting.pm | 0 bad/App/Yath/Option.pm | 1157 +++++++++++++ bad/App/Yath/Options.pm | 935 +++++++++++ bad/App/Yath/Options/Collector.pm | 89 + bad/App/Yath/Options/Debug.pm | 338 ++++ bad/App/Yath/Options/Display.pm | 237 +++ bad/App/Yath/Options/Finder.pm | 391 +++++ bad/App/Yath/Options/Logging.pm | 169 ++ bad/App/Yath/Options/Persist.pm | 68 + bad/App/Yath/Options/PreCommand.pm | 177 ++ bad/App/Yath/Options/Run.pm | 231 +++ bad/App/Yath/Options/Runner.pm | 362 +++++ bad/App/Yath/Options/Workspace.pm | 115 ++ {lib => bad}/App/Yath/Plugin.pm | 0 {lib => bad}/App/Yath/Plugin/Cover.pm | 0 {lib => bad}/App/Yath/Plugin/Git.pm | 0 {lib => bad}/App/Yath/Plugin/Notify.pm | 0 {lib => bad}/App/Yath/Plugin/SysInfo.pm | 0 {lib => bad}/App/Yath/Plugin/YathUI.pm | 0 {lib => bad}/App/Yath/Tester.pm | 0 bad/App/Yath/Util.pm | 369 +++++ {lib => bad}/Test2/Formatter/QVF.pm | 0 bad/Test2/Formatter/Stream.pm | 481 ++++++ bad/Test2/Formatter/Test2.pm | 804 ++++++++++ bad/Test2/Formatter/Test2/Composer.pm | 507 ++++++ bad/Test2/Harness.pm | 60 + bad/Test2/Harness/Auditor.pm | 176 ++ bad/Test2/Harness/Auditor/TimeTracker.pm | 370 +++++ bad/Test2/Harness/Auditor/Watcher.pm | 488 ++++++ bad/Test2/Harness/Collector.pm | 440 +++++ bad/Test2/Harness/Collector/JobDir.pm | 806 ++++++++++ bad/Test2/Harness/Collector/TapParser.pm | 383 +++++ bad/Test2/Harness/Event.pm | 216 +++ bad/Test2/Harness/Finder.pm | 940 +++++++++++ bad/Test2/Harness/IPC.pm | 520 ++++++ bad/Test2/Harness/IPC/Model.pm | 48 + bad/Test2/Harness/IPC/Model/AtomicPipe.pm | 198 +++ bad/Test2/Harness/IPC/Model/FilePipeHybrid.pm | 56 + bad/Test2/Harness/IPC/Model/Files.pm | 149 ++ bad/Test2/Harness/IPC/Process.pm | 134 ++ bad/Test2/Harness/IPC/SharedState.pm | 330 ++++ {lib => bad}/Test2/Harness/Log.pm | 0 .../Test2/Harness/Log/CoverageAggregator.pm | 0 .../Harness/Log/CoverageAggregator/ByRun.pm | 0 .../Harness/Log/CoverageAggregator/ByTest.pm | 0 {lib => bad}/Test2/Harness/Plugin.pm | 0 bad/Test2/Harness/Renderer.pm | 154 ++ bad/Test2/Harness/Renderer/Formatter.pm | 215 +++ bad/Test2/Harness/Run.pm | 182 +++ bad/Test2/Harness/Runner.pm | 681 ++++++++ bad/Test2/Harness/Runner/Constants.pm | 72 + bad/Test2/Harness/Runner/DepTracer.pm | 283 ++++ bad/Test2/Harness/Runner/Job.pm | 827 ++++++++++ bad/Test2/Harness/Runner/Preload.pm | 569 +++++++ bad/Test2/Harness/Runner/Preload/Stage.pm | 159 ++ bad/Test2/Harness/Runner/Preloader.pm | 684 ++++++++ bad/Test2/Harness/Runner/Preloader/Stage.pm | 62 + bad/Test2/Harness/Runner/Reloader.pm | 338 ++++ bad/Test2/Harness/Runner/Resource.pm | 597 +++++++ bad/Test2/Harness/Runner/Resource/JobCount.pm | 168 ++ .../Harness/Runner/Resource/SharedJobSlots.pm | 439 +++++ .../Runner/Resource/SharedJobSlots/Config.pm | 178 ++ .../Runner/Resource/SharedJobSlots/State.pm | 384 +++++ bad/Test2/Harness/Runner/Run.pm | 92 ++ bad/Test2/Harness/Runner/Scheduler.pm | 57 + bad/Test2/Harness/Runner/Scheduler/Default.pm | 1194 ++++++++++++++ bad/Test2/Harness/Runner/Spawn.pm | 89 + {lib => bad}/Test2/Harness/Settings.pm | 0 {lib => bad}/Test2/Harness/Settings/Prefix.pm | 0 bad/Test2/Harness/State.pm | 765 +++++++++ bad/Test2/Harness/State/Instance.pm | 133 ++ bad/Test2/Harness/TestFile.pm | 695 ++++++++ bad/Test2/Harness/Util.pm | 635 ++++++++ bad/Test2/Harness/Util/File.pm | 256 +++ bad/Test2/Harness/Util/File/JSON.pm | 91 ++ bad/Test2/Harness/Util/File/JSONL.pm | 91 ++ bad/Test2/Harness/Util/File/Stream.pm | 218 +++ bad/Test2/Harness/Util/File/Value.pm | 100 ++ bad/Test2/Harness/Util/HashBase.pm | 473 ++++++ bad/Test2/Harness/Util/IPC.pm | 326 ++++ bad/Test2/Harness/Util/JSON.pm | 263 +++ bad/Test2/Harness/Util/Queue.pm | 213 +++ bad/Test2/Harness/Util/Term.pm | 104 ++ bad/Test2/Harness/Util/UUID.pm | 85 + {lib => bad}/Test2/Tools/HarnessTester.pm | 0 demo.pl | 106 ++ foo_command.pm | 19 + lib/Test2/Harness/IPC/Protocol/IPSocket.pm | 0 lib/Test2/Harness/IPC/Protocol/UnixSocket.pm | 0 lib2.0/App/Yath.pm | 982 ++++++++++++ lib2.0/App/Yath/Command.pm | 191 +++ lib2.0/App/Yath/Command/foo.pm | 66 + lib2.0/App/Yath/Command/help.pm | 98 ++ lib2.0/App/Yath/Command/run.pm | 11 + lib2.0/App/Yath/Command/runner.pm | 632 ++++++++ lib2.0/App/Yath/Command/test.pm | 1112 +++++++++++++ lib2.0/App/Yath/Command/versions.pm | 34 + lib2.0/App/Yath/Finder.pm | 911 +++++++++++ lib2.0/App/Yath/Finder/MultiProject.pm | 56 + lib2.0/App/Yath/Harness.pm | 34 + lib2.0/App/Yath/Options.pm | 25 + lib2.0/App/Yath/Options/Finder.pm | 282 ++++ lib2.0/App/Yath/Options/Harness.pm | 142 ++ lib2.0/App/Yath/Options/Renderer.pm | 146 ++ lib2.0/App/Yath/Options/Resource.pm | 29 + lib2.0/App/Yath/Options/Run.pm | 228 +++ lib2.0/App/Yath/Options/Runner.pm | 72 + lib2.0/App/Yath/Options/Scheduler.pm | 150 ++ lib2.0/App/Yath/Options/Tests.pm | 227 +++ lib2.0/App/Yath/Options/Yath.pm | 157 ++ lib2.0/App/Yath/Plugin.pm | 180 +++ lib2.0/App/Yath/Renderer.pm | 114 ++ lib2.0/App/Yath/Renderer/Default.pm | 165 ++ lib2.0/App/Yath/Renderer/JSON.pm | 34 + lib2.0/App/Yath/Renderer/JSONL.pm | 40 + lib2.0/App/Yath/Resource.pm | 30 + lib2.0/App/Yath/Resource/Jobs.pm | 118 ++ lib2.0/Getopt/Yath.pm | 788 +++++++++ lib2.0/Getopt/Yath/Instance.pm | 522 ++++++ lib2.0/Getopt/Yath/Option.pm | 592 +++++++ lib2.0/Getopt/Yath/Option/Auto.pm | 27 + lib2.0/Getopt/Yath/Option/AutoList.pm | 15 + lib2.0/Getopt/Yath/Option/AutoMap.pm | 19 + lib2.0/Getopt/Yath/Option/Bool.pm | 39 + lib2.0/Getopt/Yath/Option/BoolMap.pm | 83 + lib2.0/Getopt/Yath/Option/Count.pm | 57 + lib2.0/Getopt/Yath/Option/List.pm | 94 ++ lib2.0/Getopt/Yath/Option/Map.pm | 129 ++ lib2.0/Getopt/Yath/Option/Scalar.pm | 31 + lib2.0/Getopt/Yath/Settings.pm | 68 + lib2.0/Getopt/Yath/Settings/Group.pm | 82 + lib2.0/Getopt/Yath/Term.pm | 54 + lib2.0/IPC/StateFile.pm | 512 ++++++ lib2.0/IPC/StateFile/RPCObject.pm | 124 ++ lib2.0/IPC/StateFile/RPCObject/Process.pm | 131 ++ lib2.0/Test2/Formatter/Stream.pm | 518 ++++++ lib2.0/Test2/Formatter/Test2.pm | 808 ++++++++++ lib2.0/Test2/Formatter/Test2/Composer.pm | 507 ++++++ lib2.0/Test2/Harness.pm | 833 ++++++++++ lib2.0/Test2/Harness/Aggregator.pm | 156 ++ lib2.0/Test2/Harness/Collector.pm | 712 ++++++++ lib2.0/Test2/Harness/Collector/Auditor.pm | 576 +++++++ lib2.0/Test2/Harness/Collector/IOParser.pm | 128 ++ .../Harness/Collector/IOParser/Stream.pm | 47 + lib2.0/Test2/Harness/Collector/TapParser.pm | 383 +++++ lib2.0/Test2/Harness/Event.pm | 216 +++ lib2.0/Test2/Harness/Plugin.pm | 349 ++++ lib2.0/Test2/Harness/Resource.pm | 19 + lib2.0/Test2/Harness/Run.pm | 200 +++ lib2.0/Test2/Harness/Runner.pm | 441 +++++ lib2.0/Test2/Harness/Runner/Preload.pm | 569 +++++++ lib2.0/Test2/Harness/Runner/Preload/Stage.pm | 174 ++ lib2.0/Test2/Harness/Scheduler.pm | 1427 +++++++++++++++++ lib2.0/Test2/Harness/Task.pm | 850 ++++++++++ lib2.0/Test2/Harness/Task/TestFile.pm | 754 +++++++++ lib2.0/Test2/Harness/Util.pm | 635 ++++++++ lib2.0/Test2/Harness/Util/File.pm | 256 +++ lib2.0/Test2/Harness/Util/File/JSON.pm | 91 ++ lib2.0/Test2/Harness/Util/File/JSONL.pm | 91 ++ lib2.0/Test2/Harness/Util/File/Stream.pm | 226 +++ lib2.0/Test2/Harness/Util/HashBase.pm | 496 ++++++ lib2.0/Test2/Harness/Util/IPC.pm | 70 + lib2.0/Test2/Harness/Util/JSON.pm | 263 +++ lib2.0/Test2/Harness/Util/Term.pm | 104 ++ lib2.0/Test2/Harness/Util/UUID.pm | 85 + libold2/App/Yath.pm | 879 ++++++++++ libold2/App/Yath/Command.pm | 383 +++++ libold2/App/Yath/Command/abort.pm | 68 + libold2/App/Yath/Command/aggregator.pm | 47 + libold2/App/Yath/Command/auditor.pm | 58 + libold2/App/Yath/Command/collector.pm | 266 +++ libold2/App/Yath/Command/do.pm | 41 + libold2/App/Yath/Command/failed.pm | 147 ++ libold2/App/Yath/Command/help.pm | 96 ++ libold2/App/Yath/Command/init.pm | 66 + libold2/App/Yath/Command/kill.pm | 54 + libold2/App/Yath/Command/one.pm | 90 ++ libold2/App/Yath/Command/projects.pm | 26 + libold2/App/Yath/Command/ps.pm | 76 + libold2/App/Yath/Command/reload.pm | 52 + libold2/App/Yath/Command/render.pm | 115 ++ libold2/App/Yath/Command/replay.pm | 109 ++ .../App/Yath/Command/resources.pm | 13 +- libold2/App/Yath/Command/run.pm | 242 +++ {lib => libold2}/App/Yath/Command/runner.pm | 9 +- libold2/App/Yath/Command/spawn.pm | 205 +++ libold2/App/Yath/Command/speedtag.pm | 189 +++ libold2/App/Yath/Command/start.pm | 207 +++ libold2/App/Yath/Command/status.pm | 148 ++ libold2/App/Yath/Command/stop.pm | 56 + libold2/App/Yath/Command/test.pm | 935 +++++++++++ libold2/App/Yath/Command/times.pm | 150 ++ libold2/App/Yath/Command/watch.pm | 100 ++ libold2/App/Yath/Command/which.pm | 49 + libold2/App/Yath/Converting.pm | 105 ++ libold2/App/Yath/Instance.pm | 389 +++++ libold2/App/Yath/Option.pm | 1157 +++++++++++++ libold2/App/Yath/Options.pm | 935 +++++++++++ libold2/App/Yath/Options/Collector.pm | 89 + libold2/App/Yath/Options/Debug.pm | 338 ++++ libold2/App/Yath/Options/Display.pm | 237 +++ libold2/App/Yath/Options/Finder.pm | 391 +++++ libold2/App/Yath/Options/Logging.pm | 169 ++ libold2/App/Yath/Options/Persist.pm | 68 + libold2/App/Yath/Options/PreCommand.pm | 177 ++ libold2/App/Yath/Options/Run.pm | 231 +++ libold2/App/Yath/Options/Runner.pm | 362 +++++ libold2/App/Yath/Options/Workspace.pm | 115 ++ libold2/App/Yath/Plugin.pm | 180 +++ libold2/App/Yath/Plugin/Cover.pm | 458 ++++++ libold2/App/Yath/Plugin/Git.pm | 208 +++ libold2/App/Yath/Plugin/Notify.pm | 631 ++++++++ libold2/App/Yath/Plugin/SysInfo.pm | 115 ++ libold2/App/Yath/Plugin/YathUI.pm | 362 +++++ libold2/App/Yath/Tester.pm | 451 ++++++ libold2/App/Yath/Util.pm | 369 +++++ libold2/Test2/Formatter/QVF.pm | 139 ++ libold2/Test2/Formatter/Stream.pm | 518 ++++++ libold2/Test2/Formatter/Test2.pm | 811 ++++++++++ libold2/Test2/Formatter/Test2/Composer.pm | 507 ++++++ libold2/Test2/Harness.pm | 60 + libold2/Test2/Harness/Aggregator.pm | 134 ++ libold2/Test2/Harness/Auditor.pm | 176 ++ libold2/Test2/Harness/Collector.pm | 436 +++++ libold2/Test2/Harness/Collector/Auditor.pm | 570 +++++++ libold2/Test2/Harness/Collector/IOParser.pm | 139 ++ .../Harness/Collector/IOParser/Stream.pm | 47 + libold2/Test2/Harness/Collector/JobDir.pm | 806 ++++++++++ libold2/Test2/Harness/Collector/TapParser.pm | 383 +++++ libold2/Test2/Harness/Event.pm | 216 +++ libold2/Test2/Harness/Finder.pm | 940 +++++++++++ libold2/Test2/Harness/IPC.pm | 520 ++++++ libold2/Test2/Harness/IPC/Model.pm | 48 + libold2/Test2/Harness/IPC/Model/AtomicPipe.pm | 198 +++ .../Test2/Harness/IPC/Model/FilePipeHybrid.pm | 56 + libold2/Test2/Harness/IPC/Model/Files.pm | 149 ++ libold2/Test2/Harness/IPC/Process.pm | 134 ++ libold2/Test2/Harness/IPC/SharedState.pm | 330 ++++ libold2/Test2/Harness/Log.pm | 289 ++++ .../Test2/Harness/Log/CoverageAggregator.pm | 405 +++++ .../Harness/Log/CoverageAggregator/ByRun.pm | 220 +++ .../Harness/Log/CoverageAggregator/ByTest.pm | 218 +++ libold2/Test2/Harness/Log/TimeTracker.pm | 370 +++++ libold2/Test2/Harness/Plugin.pm | 349 ++++ libold2/Test2/Harness/Renderer.pm | 154 ++ libold2/Test2/Harness/Renderer/Formatter.pm | 215 +++ libold2/Test2/Harness/Run.pm | 182 +++ libold2/Test2/Harness/Runner.pm | 692 ++++++++ libold2/Test2/Harness/Runner/Constants.pm | 72 + libold2/Test2/Harness/Runner/DepTracer.pm | 283 ++++ libold2/Test2/Harness/Runner/Job.pm | 828 ++++++++++ libold2/Test2/Harness/Runner/Preload.pm | 569 +++++++ libold2/Test2/Harness/Runner/Preload/Stage.pm | 159 ++ libold2/Test2/Harness/Runner/Preloader.pm | 665 ++++++++ .../Test2/Harness/Runner/Preloader/Stage.pm | 62 + libold2/Test2/Harness/Runner/Reloader.pm | 338 ++++ libold2/Test2/Harness/Runner/Resource.pm | 597 +++++++ .../Test2/Harness/Runner/Resource/JobCount.pm | 168 ++ .../Harness/Runner/Resource/SharedJobSlots.pm | 439 +++++ .../Runner/Resource/SharedJobSlots/Config.pm | 178 ++ .../Runner/Resource/SharedJobSlots/State.pm | 384 +++++ libold2/Test2/Harness/Runner/Run.pm | 130 ++ libold2/Test2/Harness/Runner/Spawn.pm | 89 + libold2/Test2/Harness/Runner/State.pm | 875 ++++++++++ libold2/Test2/Harness/Settings.pm | 197 +++ libold2/Test2/Harness/Settings/Prefix.pm | 188 +++ libold2/Test2/Harness/State.pm | 301 ++++ libold2/Test2/Harness/State/Instance.pm | 111 ++ libold2/Test2/Harness/TestFile.pm | 695 ++++++++ libold2/Test2/Harness/Util.pm | 651 ++++++++ libold2/Test2/Harness/Util/File.pm | 256 +++ libold2/Test2/Harness/Util/File/JSON.pm | 91 ++ libold2/Test2/Harness/Util/File/JSONL.pm | 91 ++ libold2/Test2/Harness/Util/File/Stream.pm | 222 +++ libold2/Test2/Harness/Util/File/Value.pm | 100 ++ libold2/Test2/Harness/Util/HashBase.pm | 473 ++++++ libold2/Test2/Harness/Util/IPC.pm | 336 ++++ libold2/Test2/Harness/Util/JSON.pm | 263 +++ libold2/Test2/Harness/Util/Queue.pm | 213 +++ libold2/Test2/Harness/Util/Term.pm | 104 ++ libold2/Test2/Harness/Util/UUID.pm | 85 + libold2/Test2/Tools/HarnessTester.pm | 179 +++ libx/Test2/Formatter/Test2.pm | 804 ++++++++++ libx/Test2/Formatter/Test2/Composer.pm | 507 ++++++ libx/Test2/Harness.pm | 60 + libx/Test2/Harness/IPC/Model.pm | 48 + libx/Test2/Harness/IPC/Model/AtomicPipe.pm | 198 +++ libx/Test2/Harness/IPC/Model/Files.pm | 149 ++ libx/Test2/Harness/IPC/SharedState.pm | 330 ++++ libx/Test2/Harness/State.pm | 324 ++++ libx/Test2/Harness/State/Instance.pm | 67 + libx/Test2/Harness/Util.pm | 635 ++++++++ libx/Test2/Harness/Util/File.pm | 256 +++ libx/Test2/Harness/Util/File/JSON.pm | 91 ++ libx/Test2/Harness/Util/File/JSONL.pm | 91 ++ libx/Test2/Harness/Util/File/Stream.pm | 207 +++ libx/Test2/Harness/Util/File/Value.pm | 100 ++ libx/Test2/Harness/Util/HashBase.pm | 473 ++++++ libx/Test2/Harness/Util/IPC.pm | 326 ++++ libx/Test2/Harness/Util/JSON.pm | 263 +++ libx/Test2/Harness/Util/Queue.pm | 213 +++ libx/Test2/Harness/Util/Term.pm | 104 ++ libx/Test2/Harness/Util/UUID.pm | 85 + libx/Test2/Tools/HarnessTester.pm | 179 +++ liby/App/Yath.pm | 879 ++++++++++ liby/App/Yath/Command.pm | 383 +++++ liby/App/Yath/Command/abort.pm | 68 + liby/App/Yath/Command/aggregator.pm | 46 + liby/App/Yath/Command/auditor.pm | 58 + liby/App/Yath/Command/collector.pm | 167 ++ liby/App/Yath/Command/do.pm | 41 + liby/App/Yath/Command/failed.pm | 147 ++ liby/App/Yath/Command/help.pm | 96 ++ liby/App/Yath/Command/init.pm | 66 + liby/App/Yath/Command/kill.pm | 54 + liby/App/Yath/Command/one.pm | 790 +++++++++ liby/App/Yath/Command/projects.pm | 26 + liby/App/Yath/Command/ps.pm | 76 + liby/App/Yath/Command/reload.pm | 52 + liby/App/Yath/Command/replay.pm | 109 ++ liby/App/Yath/Command/resources.pm | 160 ++ liby/App/Yath/Command/run.pm | 242 +++ liby/App/Yath/Command/runner.pm | 519 ++++++ liby/App/Yath/Command/spawn.pm | 205 +++ liby/App/Yath/Command/speedtag.pm | 189 +++ liby/App/Yath/Command/start.pm | 207 +++ liby/App/Yath/Command/status.pm | 148 ++ liby/App/Yath/Command/stop.pm | 56 + liby/App/Yath/Command/test.pm | 935 +++++++++++ liby/App/Yath/Command/times.pm | 150 ++ liby/App/Yath/Command/watch.pm | 100 ++ liby/App/Yath/Command/which.pm | 49 + liby/App/Yath/Converting.pm | 105 ++ liby/App/Yath/Option.pm | 1157 +++++++++++++ liby/App/Yath/Options.pm | 935 +++++++++++ liby/App/Yath/Options/Collector.pm | 89 + liby/App/Yath/Options/Debug.pm | 338 ++++ liby/App/Yath/Options/Display.pm | 237 +++ liby/App/Yath/Options/Finder.pm | 391 +++++ liby/App/Yath/Options/Logging.pm | 169 ++ liby/App/Yath/Options/Persist.pm | 68 + liby/App/Yath/Options/PreCommand.pm | 177 ++ liby/App/Yath/Options/Run.pm | 231 +++ liby/App/Yath/Options/Runner.pm | 362 +++++ liby/App/Yath/Options/Workspace.pm | 115 ++ liby/App/Yath/Plugin.pm | 180 +++ liby/App/Yath/Plugin/Cover.pm | 458 ++++++ liby/App/Yath/Plugin/Git.pm | 208 +++ liby/App/Yath/Plugin/Notify.pm | 631 ++++++++ liby/App/Yath/Plugin/SysInfo.pm | 115 ++ liby/App/Yath/Plugin/YathUI.pm | 362 +++++ liby/App/Yath/Tester.pm | 451 ++++++ liby/App/Yath/Util.pm | 369 +++++ liby/Test2/Formatter/QVF.pm | 139 ++ liby/Test2/Formatter/Stream.pm | 518 ++++++ liby/Test2/Formatter/Test2.pm | 804 ++++++++++ liby/Test2/Formatter/Test2/Composer.pm | 507 ++++++ liby/Test2/Harness.pm | 60 + liby/Test2/Harness/Aggregator.pm | 140 ++ liby/Test2/Harness/Auditor.pm | 176 ++ liby/Test2/Harness/Auditor/TimeTracker.pm | 370 +++++ liby/Test2/Harness/Auditor/Watcher.pm | 488 ++++++ liby/Test2/Harness/Collector.pm | 442 +++++ liby/Test2/Harness/Collector/JobDir.pm | 806 ++++++++++ liby/Test2/Harness/Collector/TapParser.pm | 383 +++++ liby/Test2/Harness/Event.pm | 216 +++ liby/Test2/Harness/Finder.pm | 940 +++++++++++ liby/Test2/Harness/IPC.pm | 520 ++++++ liby/Test2/Harness/IPC/Model.pm | 48 + liby/Test2/Harness/IPC/Model/AtomicPipe.pm | 198 +++ .../Test2/Harness/IPC/Model/FilePipeHybrid.pm | 56 + liby/Test2/Harness/IPC/Model/Files.pm | 149 ++ liby/Test2/Harness/IPC/Process.pm | 134 ++ liby/Test2/Harness/IPC/SharedState.pm | 330 ++++ liby/Test2/Harness/Log.pm | 289 ++++ liby/Test2/Harness/Log/CoverageAggregator.pm | 405 +++++ .../Harness/Log/CoverageAggregator/ByRun.pm | 220 +++ .../Harness/Log/CoverageAggregator/ByTest.pm | 218 +++ liby/Test2/Harness/Plugin.pm | 349 ++++ liby/Test2/Harness/Renderer.pm | 154 ++ liby/Test2/Harness/Renderer/Formatter.pm | 215 +++ liby/Test2/Harness/Run.pm | 182 +++ liby/Test2/Harness/Runner.pm | 692 ++++++++ liby/Test2/Harness/Runner/Constants.pm | 72 + liby/Test2/Harness/Runner/DepTracer.pm | 283 ++++ liby/Test2/Harness/Runner/Job.pm | 828 ++++++++++ liby/Test2/Harness/Runner/Preload.pm | 569 +++++++ liby/Test2/Harness/Runner/Preload/Stage.pm | 159 ++ liby/Test2/Harness/Runner/Preloader.pm | 665 ++++++++ liby/Test2/Harness/Runner/Preloader/Stage.pm | 62 + liby/Test2/Harness/Runner/Reloader.pm | 338 ++++ liby/Test2/Harness/Runner/Resource.pm | 597 +++++++ .../Test2/Harness/Runner/Resource/JobCount.pm | 168 ++ .../Harness/Runner/Resource/SharedJobSlots.pm | 439 +++++ .../Runner/Resource/SharedJobSlots/Config.pm | 178 ++ .../Runner/Resource/SharedJobSlots/State.pm | 384 +++++ liby/Test2/Harness/Runner/Run.pm | 130 ++ liby/Test2/Harness/Runner/Spawn.pm | 89 + liby/Test2/Harness/Runner/State.pm | 875 ++++++++++ liby/Test2/Harness/Settings.pm | 197 +++ liby/Test2/Harness/Settings/Prefix.pm | 188 +++ liby/Test2/Harness/State.pm | 302 ++++ liby/Test2/Harness/State/Instance.pm | 111 ++ liby/Test2/Harness/TestFile.pm | 695 ++++++++ liby/Test2/Harness/Util.pm | 650 ++++++++ liby/Test2/Harness/Util/Collector.pm | 344 ++++ liby/Test2/Harness/Util/Collector.pm2 | 281 ++++ liby/Test2/Harness/Util/File.pm | 256 +++ liby/Test2/Harness/Util/File/JSON.pm | 91 ++ liby/Test2/Harness/Util/File/JSONL.pm | 91 ++ liby/Test2/Harness/Util/File/Stream.pm | 221 +++ liby/Test2/Harness/Util/File/Value.pm | 100 ++ liby/Test2/Harness/Util/HashBase.pm | 473 ++++++ liby/Test2/Harness/Util/IPC.pm | 326 ++++ liby/Test2/Harness/Util/JSON.pm | 263 +++ liby/Test2/Harness/Util/Queue.pm | 213 +++ liby/Test2/Harness/Util/Term.pm | 104 ++ liby/Test2/Harness/Util/UUID.pm | 85 + liby/Test2/Tools/HarnessTester.pm | 179 +++ moreold/Base.pm | 390 +++++ moreold/Shared.pm | 238 +++ moreold/TxnState.pm | 75 + release-scripts/generate_command_pod.pl | 56 +- scripts/yath-stage | 330 ++++ t/HashBase.t | 4 + t/acceptence/getopt_yath.t | 797 +++++++++ t/acceptence/ipc_statefile.t | 335 ++++ t/fake.t | 55 + t/integration/concurrency.t | 118 -- t/integration/concurrency/a.tx | 7 - t/integration/concurrency/b.tx | 7 - t/integration/concurrency/c.tx | 7 - t/integration/concurrency/d.tx | 7 - t/integration/concurrency/e.tx | 7 - t/integration/coverage.t | 345 ---- t/integration/coverage/a.tx | 46 - t/integration/coverage/b.tx | 21 - t/integration/coverage/c.tx | 34 - t/integration/coverage/lib/Ax.pm | 11 - t/integration/coverage/lib/Bx.pm | 7 - t/integration/coverage/lib/Cx.pm | 7 - t/integration/coverage/lib/Manager.pm | 33 - t/integration/coverage/lib/Plugin.pm | 22 - t/integration/coverage/once.tx | 18 - t/integration/coverage/open.tx | 22 - t/integration/coverage/x.tx | 21 - t/integration/coverage2.t | 310 ---- t/integration/coverage3.t | 231 --- t/integration/coverage4.t | 231 --- t/integration/encoding.t | 58 - t/integration/encoding/no-plugin.tx | 29 - t/integration/encoding/plugin.tx | 29 - t/integration/failed.t | 42 - t/integration/failed/fail.tx | 5 - t/integration/failed/pass.tx | 5 - t/integration/failure_cases.t | 52 - t/integration/failure_cases/badplan.tx | 7 - .../buffered_subtest_abrupt_end.tx | 14 - .../buffered_subtest_abrupt_end_nested.tx | 17 - t/integration/failure_cases/dupnums.tx | 10 - t/integration/failure_cases/exit.tx | 8 - t/integration/failure_cases/missingnums.tx | 7 - t/integration/failure_cases/nested_subtest.tx | 11 - .../failure_cases/nested_subtest_exception.tx | 40 - t/integration/failure_cases/noplan.tx | 6 - t/integration/failure_cases/notok.tx | 5 - t/integration/failure_cases/parse_error.tx | 9 - .../failure_cases/post_exit_timeout.tx | 8 - t/integration/failure_cases/subtest.tx | 7 - t/integration/failure_cases/timeout.tx | 6 - t/integration/help.t | 68 - t/integration/includes.t | 55 - t/integration/includes/.yath.rc | 1 - t/integration/includes/default-i.tx | 25 - t/integration/includes/default.tx | 24 - t/integration/includes/dot-last.tx | 27 - t/integration/includes/not-perl.pl | 35 - t/integration/includes/not-perl.sh | 2 - t/integration/includes/order-ibili.tx | 32 - t/integration/includes/order-ilibi.tx | 32 - t/integration/init.t | 38 - t/integration/log_dir.t | 34 - t/integration/log_dir/foo.tx | 5 - t/integration/persist.t | 100 -- t/integration/persist/fail.txx | 5 - t/integration/persist/pass.tx | 5 - t/integration/plugin.t | 90 -- t/integration/plugin/a.tx | 4 - t/integration/plugin/b.tx | 4 - t/integration/plugin/c.tx | 4 - t/integration/plugin/d.tx | 6 - .../plugin/lib/App/Yath/Plugin/TestPlugin.pm | 187 --- t/integration/plugin/test.tx | 7 - t/integration/preload.t | 127 -- t/integration/preload/aaa.tx | 6 - t/integration/preload/bbb.tx | 6 - t/integration/preload/ccc.tx | 31 - t/integration/preload/fast.tx | 6 - t/integration/preload/lib/AAA.pm | 2 - t/integration/preload/lib/BBB.pm | 2 - t/integration/preload/lib/Broken.pm | 3 - t/integration/preload/lib/CCC.pm | 2 - t/integration/preload/lib/FAST.pm | 2 - t/integration/preload/lib/TestBadPreload.pm | 12 - t/integration/preload/lib/TestPreload.pm | 72 - .../preload/lib/TestSimplePreload.pm | 3 - t/integration/preload/no_preload.tx | 6 - t/integration/preload/preload_test.tx | 5 - t/integration/preload/retry.tx | 6 - t/integration/preload/simple_test.tx | 5 - t/integration/preload/slow.tx | 7 - t/integration/projects.t | 77 - t/integration/projects/bar/lib/Bar.pm | 3 - t/integration/projects/bar/lib/Baz.pm | 1 - t/integration/projects/bar/lib/Foo.pm | 1 - t/integration/projects/bar/t/pass.tx | 11 - t/integration/projects/baz/lib/Bar.pm | 1 - t/integration/projects/baz/lib/Baz.pm | 3 - t/integration/projects/baz/lib/Foo.pm | 1 - t/integration/projects/baz/t/fail.txx | 5 - t/integration/projects/baz/t/pass.tx | 11 - t/integration/projects/foo/lib/Bar.pm | 1 - t/integration/projects/foo/lib/Baz.pm | 1 - t/integration/projects/foo/lib/Foo.pm | 3 - t/integration/projects/foo/t/pass.tx | 11 - t/integration/reload.t | 455 ------ t/integration/reload/lib/Preload.pm | 54 - t/integration/reload/lib/Preload/A.pm | 13 - t/integration/reload/lib/Preload/B.pm | 15 - t/integration/reload/lib/Preload/Churn.pm | 30 - .../reload/lib/Preload/ExceptionA.pm | 14 - .../reload/lib/Preload/ExceptionB.pm | 15 - t/integration/reload/lib/Preload/ExporterA.pm | 16 - t/integration/reload/lib/Preload/ExporterB.pm | 18 - t/integration/reload/lib/Preload/IncChange.pm | 9 - t/integration/reload/lib/Preload/WarningA.pm | 14 - t/integration/reload/lib/Preload/WarningB.pm | 14 - t/integration/reload/lib/Preload/nonperl1 | 1 - t/integration/reload/lib/Preload/nonperl2 | 1 - t/integration/reload_syntax_error.t | 100 -- t/integration/reload_syntax_error.tx | 4 - t/integration/replay.t | 60 - t/integration/replay/fail.tx | 5 - t/integration/replay/pass.tx | 5 - t/integration/resource.t | 102 -- t/integration/resource/Resource.pm | 78 - t/integration/resource/a.tx | 8 - t/integration/resource/b.tx | 8 - t/integration/resource/c.tx | 8 - t/integration/resource/d.tx | 8 - t/integration/retry-symlinks/retry.tx | 30 - t/integration/retry-symlinks/symlink.tl | 1 - t/integration/retry-timeout/retry.tx | 24 - t/integration/retry.t | 139 -- t/integration/retry/retry.tx | 30 - t/integration/signals.t | 26 - t/integration/signals/abrt_or_iot.t | 17 - t/integration/slots_per_job.t | 9 - t/integration/slots_per_job2.t | 11 - t/integration/slots_per_job3.t | 10 - t/integration/smoke.t | 83 - t/integration/smoke/a.tx | 5 - t/integration/smoke/b.tx | 6 - t/integration/smoke/c.tx | 6 - t/integration/smoke/d.tx | 6 - t/integration/smoke/e.tx | 6 - t/integration/smoke/f.tx | 6 - t/integration/smoke/g.tx | 6 - t/integration/smoke/h.tx | 6 - t/integration/smoke/lib/SmokePlugin.pm | 17 - t/integration/speedtag.t | 52 - t/integration/speedtag/pass.tx | 5 - t/integration/speedtag/pass2.tx | 5 - t/integration/stamps.t | 32 - t/integration/stamps/fail.tx | 5 - .../stamps/lib/App/Yath/Plugin/TestPlugin.pm | 16 - t/integration/stamps/pass.tx | 5 - t/integration/tapsubtest.t | 29 - t/integration/tapsubtest/test.tx | 9 - t/integration/test-broken-symlinks/keepme | 1 - t/integration/test-broken-symlinks/pass.tx | 5 - t/integration/test-durations.json | 8 - t/integration/test-durations/fast-01.tx | 5 - t/integration/test-durations/fast-02.tx | 5 - t/integration/test-durations/fast-03.tx | 5 - t/integration/test-durations/fast-04.tx | 5 - t/integration/test-durations/slow-01.tx | 5 - t/integration/test-durations/slow-02.tx | 5 - t/integration/test-inc/check-INC.tx | 18 - t/integration/test-symlinks/_base.xt | 7 - .../test-symlinks/symlink_to_base.xt | 1 - t/integration/test.t | 260 --- t/integration/test/fail.txx | 5 - t/integration/test/pass.tx | 5 - t/integration/test/pass.txxx | 7 - t/integration/times.t | 36 - t/integration/times/pass.tx | 5 - t/integration/times/pass2.tx | 5 - t/integration/verbose_env.t | 39 - t/integration/verbose_env/not_verbose.tx | 6 - t/integration/verbose_env/verbose1.tx | 6 - t/integration/verbose_env/verbose2.tx | 6 - t/lib/App/Yath/Command/broken.pm | 3 - t/lib/App/Yath/Command/fake.pm | 15 - t/lib/App/Yath/Plugin/Fail.pm | 26 - t/lib/App/Yath/Plugin/Options.pm | 12 - t/unit/App/Yath.t | 263 --- t/unit/App/Yath/Command/init.t | 48 - t/unit/App/Yath/Option.t | 447 ------ t/unit/App/Yath/Options.t | 782 --------- t/unit/App/Yath/Plugin.t | 13 - t/unit/App/Yath/Plugin/Git.script | 178 -- t/unit/App/Yath/Plugin/Git.t | 173 -- t/unit/App/Yath/Plugin/SysInfo.t | 116 -- t/unit/App/Yath/Util.t | 159 -- t/unit/Test2/Harness/Runner/DepTracer.t | 97 -- .../SharedJobSlots/.sharedjobslots.yml | 45 - .../Runner/Resource/SharedJobSlots/Config.t | 109 -- .../Runner/Resource/SharedJobSlots/State.t | 667 -------- t/unit/Test2/Harness/Settings.t | 64 - t/unit/Test2/Harness/Settings/Prefix.t | 66 - t/unit/Test2/Harness/TestFile.t | 691 -------- t/unit/Test2/Harness/Util.t | 91 -- t/unit/Test2/Harness/Util/File.t | 102 -- t/unit/Test2/Harness/Util/File/JSON.t | 25 - t/unit/Test2/Harness/Util/File/JSONL.t | 12 - t/unit/Test2/Harness/Util/File/Stream.t | 118 -- t/unit/Test2/Harness/Util/File/Value.t | 21 - t/unit/Test2/Harness/Util/JSON.t | 31 - t/unit/Test2/Harness/Util/Term.t | 10 - t/unit/Test2/Tools/HarnessTester.t | 46 - t2/builder.t | 2 + t2/ipc_reexec.t | 3 + t2/output.t | 4 +- t2/subtests.t | 2 + template.pod | 48 + templib/XXX.pm | 39 + templib/YYY.pm | 5 + xt/author/critic.t | 7 + 669 files changed, 124775 insertions(+), 9662 deletions(-) create mode 100644 .perlcriticrc rename .yath.rc => .yath.rc.xxx (100%) create mode 100644 Debug.pm create mode 100644 Workspace.pm create mode 100644 bad/App/Yath.pm create mode 100644 bad/App/Yath/Command.pm create mode 100644 bad/App/Yath/Command/abort.pm rename {lib => bad}/App/Yath/Command/auditor.pm (100%) create mode 100644 bad/App/Yath/Command/collector.pm rename {lib => bad}/App/Yath/Command/do.pm (100%) rename {lib => bad}/App/Yath/Command/failed.pm (100%) create mode 100644 bad/App/Yath/Command/help.pm rename {lib => bad}/App/Yath/Command/init.pm (100%) rename {lib => bad}/App/Yath/Command/kill.pm (100%) rename {lib => bad}/App/Yath/Command/projects.pm (100%) rename {lib => bad}/App/Yath/Command/ps.pm (97%) rename {lib => bad}/App/Yath/Command/reload.pm (100%) rename {lib => bad}/App/Yath/Command/replay.pm (100%) create mode 100644 bad/App/Yath/Command/resources.pm create mode 100644 bad/App/Yath/Command/run.pm create mode 100644 bad/App/Yath/Command/runner.pm rename {lib => bad}/App/Yath/Command/spawn.pm (100%) rename {lib => bad}/App/Yath/Command/speedtag.pm (100%) create mode 100644 bad/App/Yath/Command/start.pm rename {lib => bad}/App/Yath/Command/status.pm (99%) rename {lib => bad}/App/Yath/Command/stop.pm (96%) create mode 100644 bad/App/Yath/Command/test.pm rename {lib => bad}/App/Yath/Command/times.pm (100%) create mode 100644 bad/App/Yath/Command/watch.pm rename {lib => bad}/App/Yath/Command/which.pm (100%) rename {lib => bad}/App/Yath/Converting.pm (100%) create mode 100644 bad/App/Yath/Option.pm create mode 100644 bad/App/Yath/Options.pm create mode 100644 bad/App/Yath/Options/Collector.pm create mode 100644 bad/App/Yath/Options/Debug.pm create mode 100644 bad/App/Yath/Options/Display.pm create mode 100644 bad/App/Yath/Options/Finder.pm create mode 100644 bad/App/Yath/Options/Logging.pm create mode 100644 bad/App/Yath/Options/Persist.pm create mode 100644 bad/App/Yath/Options/PreCommand.pm create mode 100644 bad/App/Yath/Options/Run.pm create mode 100644 bad/App/Yath/Options/Runner.pm create mode 100644 bad/App/Yath/Options/Workspace.pm rename {lib => bad}/App/Yath/Plugin.pm (100%) rename {lib => bad}/App/Yath/Plugin/Cover.pm (100%) rename {lib => bad}/App/Yath/Plugin/Git.pm (100%) rename {lib => bad}/App/Yath/Plugin/Notify.pm (100%) rename {lib => bad}/App/Yath/Plugin/SysInfo.pm (100%) rename {lib => bad}/App/Yath/Plugin/YathUI.pm (100%) rename {lib => bad}/App/Yath/Tester.pm (100%) create mode 100644 bad/App/Yath/Util.pm rename {lib => bad}/Test2/Formatter/QVF.pm (100%) create mode 100644 bad/Test2/Formatter/Stream.pm create mode 100644 bad/Test2/Formatter/Test2.pm create mode 100644 bad/Test2/Formatter/Test2/Composer.pm create mode 100644 bad/Test2/Harness.pm create mode 100644 bad/Test2/Harness/Auditor.pm create mode 100644 bad/Test2/Harness/Auditor/TimeTracker.pm create mode 100644 bad/Test2/Harness/Auditor/Watcher.pm create mode 100644 bad/Test2/Harness/Collector.pm create mode 100644 bad/Test2/Harness/Collector/JobDir.pm create mode 100644 bad/Test2/Harness/Collector/TapParser.pm create mode 100644 bad/Test2/Harness/Event.pm create mode 100644 bad/Test2/Harness/Finder.pm create mode 100644 bad/Test2/Harness/IPC.pm create mode 100644 bad/Test2/Harness/IPC/Model.pm create mode 100644 bad/Test2/Harness/IPC/Model/AtomicPipe.pm create mode 100644 bad/Test2/Harness/IPC/Model/FilePipeHybrid.pm create mode 100644 bad/Test2/Harness/IPC/Model/Files.pm create mode 100644 bad/Test2/Harness/IPC/Process.pm create mode 100644 bad/Test2/Harness/IPC/SharedState.pm rename {lib => bad}/Test2/Harness/Log.pm (100%) rename {lib => bad}/Test2/Harness/Log/CoverageAggregator.pm (100%) rename {lib => bad}/Test2/Harness/Log/CoverageAggregator/ByRun.pm (100%) rename {lib => bad}/Test2/Harness/Log/CoverageAggregator/ByTest.pm (100%) rename {lib => bad}/Test2/Harness/Plugin.pm (100%) create mode 100644 bad/Test2/Harness/Renderer.pm create mode 100644 bad/Test2/Harness/Renderer/Formatter.pm create mode 100644 bad/Test2/Harness/Run.pm create mode 100644 bad/Test2/Harness/Runner.pm create mode 100644 bad/Test2/Harness/Runner/Constants.pm create mode 100644 bad/Test2/Harness/Runner/DepTracer.pm create mode 100644 bad/Test2/Harness/Runner/Job.pm create mode 100644 bad/Test2/Harness/Runner/Preload.pm create mode 100644 bad/Test2/Harness/Runner/Preload/Stage.pm create mode 100644 bad/Test2/Harness/Runner/Preloader.pm create mode 100644 bad/Test2/Harness/Runner/Preloader/Stage.pm create mode 100644 bad/Test2/Harness/Runner/Reloader.pm create mode 100644 bad/Test2/Harness/Runner/Resource.pm create mode 100644 bad/Test2/Harness/Runner/Resource/JobCount.pm create mode 100644 bad/Test2/Harness/Runner/Resource/SharedJobSlots.pm create mode 100644 bad/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm create mode 100644 bad/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm create mode 100644 bad/Test2/Harness/Runner/Run.pm create mode 100644 bad/Test2/Harness/Runner/Scheduler.pm create mode 100644 bad/Test2/Harness/Runner/Scheduler/Default.pm create mode 100644 bad/Test2/Harness/Runner/Spawn.pm rename {lib => bad}/Test2/Harness/Settings.pm (100%) rename {lib => bad}/Test2/Harness/Settings/Prefix.pm (100%) create mode 100644 bad/Test2/Harness/State.pm create mode 100644 bad/Test2/Harness/State/Instance.pm create mode 100644 bad/Test2/Harness/TestFile.pm create mode 100644 bad/Test2/Harness/Util.pm create mode 100644 bad/Test2/Harness/Util/File.pm create mode 100644 bad/Test2/Harness/Util/File/JSON.pm create mode 100644 bad/Test2/Harness/Util/File/JSONL.pm create mode 100644 bad/Test2/Harness/Util/File/Stream.pm create mode 100644 bad/Test2/Harness/Util/File/Value.pm create mode 100644 bad/Test2/Harness/Util/HashBase.pm create mode 100644 bad/Test2/Harness/Util/IPC.pm create mode 100644 bad/Test2/Harness/Util/JSON.pm create mode 100644 bad/Test2/Harness/Util/Queue.pm create mode 100644 bad/Test2/Harness/Util/Term.pm create mode 100644 bad/Test2/Harness/Util/UUID.pm rename {lib => bad}/Test2/Tools/HarnessTester.pm (100%) create mode 100755 demo.pl create mode 100644 foo_command.pm create mode 100644 lib/Test2/Harness/IPC/Protocol/IPSocket.pm create mode 100644 lib/Test2/Harness/IPC/Protocol/UnixSocket.pm create mode 100644 lib2.0/App/Yath.pm create mode 100644 lib2.0/App/Yath/Command.pm create mode 100644 lib2.0/App/Yath/Command/foo.pm create mode 100644 lib2.0/App/Yath/Command/help.pm create mode 100644 lib2.0/App/Yath/Command/run.pm create mode 100644 lib2.0/App/Yath/Command/runner.pm create mode 100644 lib2.0/App/Yath/Command/test.pm create mode 100644 lib2.0/App/Yath/Command/versions.pm create mode 100644 lib2.0/App/Yath/Finder.pm create mode 100644 lib2.0/App/Yath/Finder/MultiProject.pm create mode 100644 lib2.0/App/Yath/Harness.pm create mode 100644 lib2.0/App/Yath/Options.pm create mode 100644 lib2.0/App/Yath/Options/Finder.pm create mode 100644 lib2.0/App/Yath/Options/Harness.pm create mode 100644 lib2.0/App/Yath/Options/Renderer.pm create mode 100644 lib2.0/App/Yath/Options/Resource.pm create mode 100644 lib2.0/App/Yath/Options/Run.pm create mode 100644 lib2.0/App/Yath/Options/Runner.pm create mode 100644 lib2.0/App/Yath/Options/Scheduler.pm create mode 100644 lib2.0/App/Yath/Options/Tests.pm create mode 100644 lib2.0/App/Yath/Options/Yath.pm create mode 100644 lib2.0/App/Yath/Plugin.pm create mode 100644 lib2.0/App/Yath/Renderer.pm create mode 100644 lib2.0/App/Yath/Renderer/Default.pm create mode 100644 lib2.0/App/Yath/Renderer/JSON.pm create mode 100644 lib2.0/App/Yath/Renderer/JSONL.pm create mode 100644 lib2.0/App/Yath/Resource.pm create mode 100644 lib2.0/App/Yath/Resource/Jobs.pm create mode 100644 lib2.0/Getopt/Yath.pm create mode 100644 lib2.0/Getopt/Yath/Instance.pm create mode 100644 lib2.0/Getopt/Yath/Option.pm create mode 100644 lib2.0/Getopt/Yath/Option/Auto.pm create mode 100644 lib2.0/Getopt/Yath/Option/AutoList.pm create mode 100644 lib2.0/Getopt/Yath/Option/AutoMap.pm create mode 100644 lib2.0/Getopt/Yath/Option/Bool.pm create mode 100644 lib2.0/Getopt/Yath/Option/BoolMap.pm create mode 100644 lib2.0/Getopt/Yath/Option/Count.pm create mode 100644 lib2.0/Getopt/Yath/Option/List.pm create mode 100644 lib2.0/Getopt/Yath/Option/Map.pm create mode 100644 lib2.0/Getopt/Yath/Option/Scalar.pm create mode 100644 lib2.0/Getopt/Yath/Settings.pm create mode 100644 lib2.0/Getopt/Yath/Settings/Group.pm create mode 100644 lib2.0/Getopt/Yath/Term.pm create mode 100644 lib2.0/IPC/StateFile.pm create mode 100644 lib2.0/IPC/StateFile/RPCObject.pm create mode 100644 lib2.0/IPC/StateFile/RPCObject/Process.pm create mode 100644 lib2.0/Test2/Formatter/Stream.pm create mode 100644 lib2.0/Test2/Formatter/Test2.pm create mode 100644 lib2.0/Test2/Formatter/Test2/Composer.pm create mode 100644 lib2.0/Test2/Harness.pm create mode 100644 lib2.0/Test2/Harness/Aggregator.pm create mode 100644 lib2.0/Test2/Harness/Collector.pm create mode 100644 lib2.0/Test2/Harness/Collector/Auditor.pm create mode 100644 lib2.0/Test2/Harness/Collector/IOParser.pm create mode 100644 lib2.0/Test2/Harness/Collector/IOParser/Stream.pm create mode 100644 lib2.0/Test2/Harness/Collector/TapParser.pm create mode 100644 lib2.0/Test2/Harness/Event.pm create mode 100644 lib2.0/Test2/Harness/Plugin.pm create mode 100644 lib2.0/Test2/Harness/Resource.pm create mode 100644 lib2.0/Test2/Harness/Run.pm create mode 100644 lib2.0/Test2/Harness/Runner.pm create mode 100644 lib2.0/Test2/Harness/Runner/Preload.pm create mode 100644 lib2.0/Test2/Harness/Runner/Preload/Stage.pm create mode 100644 lib2.0/Test2/Harness/Scheduler.pm create mode 100644 lib2.0/Test2/Harness/Task.pm create mode 100644 lib2.0/Test2/Harness/Task/TestFile.pm create mode 100644 lib2.0/Test2/Harness/Util.pm create mode 100644 lib2.0/Test2/Harness/Util/File.pm create mode 100644 lib2.0/Test2/Harness/Util/File/JSON.pm create mode 100644 lib2.0/Test2/Harness/Util/File/JSONL.pm create mode 100644 lib2.0/Test2/Harness/Util/File/Stream.pm create mode 100644 lib2.0/Test2/Harness/Util/HashBase.pm create mode 100644 lib2.0/Test2/Harness/Util/IPC.pm create mode 100644 lib2.0/Test2/Harness/Util/JSON.pm create mode 100644 lib2.0/Test2/Harness/Util/Term.pm create mode 100644 lib2.0/Test2/Harness/Util/UUID.pm create mode 100644 libold2/App/Yath.pm create mode 100644 libold2/App/Yath/Command.pm create mode 100644 libold2/App/Yath/Command/abort.pm create mode 100644 libold2/App/Yath/Command/aggregator.pm create mode 100644 libold2/App/Yath/Command/auditor.pm create mode 100644 libold2/App/Yath/Command/collector.pm create mode 100644 libold2/App/Yath/Command/do.pm create mode 100644 libold2/App/Yath/Command/failed.pm create mode 100644 libold2/App/Yath/Command/help.pm create mode 100644 libold2/App/Yath/Command/init.pm create mode 100644 libold2/App/Yath/Command/kill.pm create mode 100644 libold2/App/Yath/Command/one.pm create mode 100644 libold2/App/Yath/Command/projects.pm create mode 100644 libold2/App/Yath/Command/ps.pm create mode 100644 libold2/App/Yath/Command/reload.pm create mode 100644 libold2/App/Yath/Command/render.pm create mode 100644 libold2/App/Yath/Command/replay.pm rename {lib => libold2}/App/Yath/Command/resources.pm (89%) create mode 100644 libold2/App/Yath/Command/run.pm rename {lib => libold2}/App/Yath/Command/runner.pm (98%) create mode 100644 libold2/App/Yath/Command/spawn.pm create mode 100644 libold2/App/Yath/Command/speedtag.pm create mode 100644 libold2/App/Yath/Command/start.pm create mode 100644 libold2/App/Yath/Command/status.pm create mode 100644 libold2/App/Yath/Command/stop.pm create mode 100644 libold2/App/Yath/Command/test.pm create mode 100644 libold2/App/Yath/Command/times.pm create mode 100644 libold2/App/Yath/Command/watch.pm create mode 100644 libold2/App/Yath/Command/which.pm create mode 100644 libold2/App/Yath/Converting.pm create mode 100644 libold2/App/Yath/Instance.pm create mode 100644 libold2/App/Yath/Option.pm create mode 100644 libold2/App/Yath/Options.pm create mode 100644 libold2/App/Yath/Options/Collector.pm create mode 100644 libold2/App/Yath/Options/Debug.pm create mode 100644 libold2/App/Yath/Options/Display.pm create mode 100644 libold2/App/Yath/Options/Finder.pm create mode 100644 libold2/App/Yath/Options/Logging.pm create mode 100644 libold2/App/Yath/Options/Persist.pm create mode 100644 libold2/App/Yath/Options/PreCommand.pm create mode 100644 libold2/App/Yath/Options/Run.pm create mode 100644 libold2/App/Yath/Options/Runner.pm create mode 100644 libold2/App/Yath/Options/Workspace.pm create mode 100644 libold2/App/Yath/Plugin.pm create mode 100644 libold2/App/Yath/Plugin/Cover.pm create mode 100644 libold2/App/Yath/Plugin/Git.pm create mode 100644 libold2/App/Yath/Plugin/Notify.pm create mode 100644 libold2/App/Yath/Plugin/SysInfo.pm create mode 100644 libold2/App/Yath/Plugin/YathUI.pm create mode 100644 libold2/App/Yath/Tester.pm create mode 100644 libold2/App/Yath/Util.pm create mode 100644 libold2/Test2/Formatter/QVF.pm create mode 100644 libold2/Test2/Formatter/Stream.pm create mode 100644 libold2/Test2/Formatter/Test2.pm create mode 100644 libold2/Test2/Formatter/Test2/Composer.pm create mode 100644 libold2/Test2/Harness.pm create mode 100644 libold2/Test2/Harness/Aggregator.pm create mode 100644 libold2/Test2/Harness/Auditor.pm create mode 100644 libold2/Test2/Harness/Collector.pm create mode 100644 libold2/Test2/Harness/Collector/Auditor.pm create mode 100644 libold2/Test2/Harness/Collector/IOParser.pm create mode 100644 libold2/Test2/Harness/Collector/IOParser/Stream.pm create mode 100644 libold2/Test2/Harness/Collector/JobDir.pm create mode 100644 libold2/Test2/Harness/Collector/TapParser.pm create mode 100644 libold2/Test2/Harness/Event.pm create mode 100644 libold2/Test2/Harness/Finder.pm create mode 100644 libold2/Test2/Harness/IPC.pm create mode 100644 libold2/Test2/Harness/IPC/Model.pm create mode 100644 libold2/Test2/Harness/IPC/Model/AtomicPipe.pm create mode 100644 libold2/Test2/Harness/IPC/Model/FilePipeHybrid.pm create mode 100644 libold2/Test2/Harness/IPC/Model/Files.pm create mode 100644 libold2/Test2/Harness/IPC/Process.pm create mode 100644 libold2/Test2/Harness/IPC/SharedState.pm create mode 100644 libold2/Test2/Harness/Log.pm create mode 100644 libold2/Test2/Harness/Log/CoverageAggregator.pm create mode 100644 libold2/Test2/Harness/Log/CoverageAggregator/ByRun.pm create mode 100644 libold2/Test2/Harness/Log/CoverageAggregator/ByTest.pm create mode 100644 libold2/Test2/Harness/Log/TimeTracker.pm create mode 100644 libold2/Test2/Harness/Plugin.pm create mode 100644 libold2/Test2/Harness/Renderer.pm create mode 100644 libold2/Test2/Harness/Renderer/Formatter.pm create mode 100644 libold2/Test2/Harness/Run.pm create mode 100644 libold2/Test2/Harness/Runner.pm create mode 100644 libold2/Test2/Harness/Runner/Constants.pm create mode 100644 libold2/Test2/Harness/Runner/DepTracer.pm create mode 100644 libold2/Test2/Harness/Runner/Job.pm create mode 100644 libold2/Test2/Harness/Runner/Preload.pm create mode 100644 libold2/Test2/Harness/Runner/Preload/Stage.pm create mode 100644 libold2/Test2/Harness/Runner/Preloader.pm create mode 100644 libold2/Test2/Harness/Runner/Preloader/Stage.pm create mode 100644 libold2/Test2/Harness/Runner/Reloader.pm create mode 100644 libold2/Test2/Harness/Runner/Resource.pm create mode 100644 libold2/Test2/Harness/Runner/Resource/JobCount.pm create mode 100644 libold2/Test2/Harness/Runner/Resource/SharedJobSlots.pm create mode 100644 libold2/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm create mode 100644 libold2/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm create mode 100644 libold2/Test2/Harness/Runner/Run.pm create mode 100644 libold2/Test2/Harness/Runner/Spawn.pm create mode 100644 libold2/Test2/Harness/Runner/State.pm create mode 100644 libold2/Test2/Harness/Settings.pm create mode 100644 libold2/Test2/Harness/Settings/Prefix.pm create mode 100644 libold2/Test2/Harness/State.pm create mode 100644 libold2/Test2/Harness/State/Instance.pm create mode 100644 libold2/Test2/Harness/TestFile.pm create mode 100644 libold2/Test2/Harness/Util.pm create mode 100644 libold2/Test2/Harness/Util/File.pm create mode 100644 libold2/Test2/Harness/Util/File/JSON.pm create mode 100644 libold2/Test2/Harness/Util/File/JSONL.pm create mode 100644 libold2/Test2/Harness/Util/File/Stream.pm create mode 100644 libold2/Test2/Harness/Util/File/Value.pm create mode 100644 libold2/Test2/Harness/Util/HashBase.pm create mode 100644 libold2/Test2/Harness/Util/IPC.pm create mode 100644 libold2/Test2/Harness/Util/JSON.pm create mode 100644 libold2/Test2/Harness/Util/Queue.pm create mode 100644 libold2/Test2/Harness/Util/Term.pm create mode 100644 libold2/Test2/Harness/Util/UUID.pm create mode 100644 libold2/Test2/Tools/HarnessTester.pm create mode 100644 libx/Test2/Formatter/Test2.pm create mode 100644 libx/Test2/Formatter/Test2/Composer.pm create mode 100644 libx/Test2/Harness.pm create mode 100644 libx/Test2/Harness/IPC/Model.pm create mode 100644 libx/Test2/Harness/IPC/Model/AtomicPipe.pm create mode 100644 libx/Test2/Harness/IPC/Model/Files.pm create mode 100644 libx/Test2/Harness/IPC/SharedState.pm create mode 100644 libx/Test2/Harness/State.pm create mode 100644 libx/Test2/Harness/State/Instance.pm create mode 100644 libx/Test2/Harness/Util.pm create mode 100644 libx/Test2/Harness/Util/File.pm create mode 100644 libx/Test2/Harness/Util/File/JSON.pm create mode 100644 libx/Test2/Harness/Util/File/JSONL.pm create mode 100644 libx/Test2/Harness/Util/File/Stream.pm create mode 100644 libx/Test2/Harness/Util/File/Value.pm create mode 100644 libx/Test2/Harness/Util/HashBase.pm create mode 100644 libx/Test2/Harness/Util/IPC.pm create mode 100644 libx/Test2/Harness/Util/JSON.pm create mode 100644 libx/Test2/Harness/Util/Queue.pm create mode 100644 libx/Test2/Harness/Util/Term.pm create mode 100644 libx/Test2/Harness/Util/UUID.pm create mode 100644 libx/Test2/Tools/HarnessTester.pm create mode 100644 liby/App/Yath.pm create mode 100644 liby/App/Yath/Command.pm create mode 100644 liby/App/Yath/Command/abort.pm create mode 100644 liby/App/Yath/Command/aggregator.pm create mode 100644 liby/App/Yath/Command/auditor.pm create mode 100644 liby/App/Yath/Command/collector.pm create mode 100644 liby/App/Yath/Command/do.pm create mode 100644 liby/App/Yath/Command/failed.pm create mode 100644 liby/App/Yath/Command/help.pm create mode 100644 liby/App/Yath/Command/init.pm create mode 100644 liby/App/Yath/Command/kill.pm create mode 100644 liby/App/Yath/Command/one.pm create mode 100644 liby/App/Yath/Command/projects.pm create mode 100644 liby/App/Yath/Command/ps.pm create mode 100644 liby/App/Yath/Command/reload.pm create mode 100644 liby/App/Yath/Command/replay.pm create mode 100644 liby/App/Yath/Command/resources.pm create mode 100644 liby/App/Yath/Command/run.pm create mode 100644 liby/App/Yath/Command/runner.pm create mode 100644 liby/App/Yath/Command/spawn.pm create mode 100644 liby/App/Yath/Command/speedtag.pm create mode 100644 liby/App/Yath/Command/start.pm create mode 100644 liby/App/Yath/Command/status.pm create mode 100644 liby/App/Yath/Command/stop.pm create mode 100644 liby/App/Yath/Command/test.pm create mode 100644 liby/App/Yath/Command/times.pm create mode 100644 liby/App/Yath/Command/watch.pm create mode 100644 liby/App/Yath/Command/which.pm create mode 100644 liby/App/Yath/Converting.pm create mode 100644 liby/App/Yath/Option.pm create mode 100644 liby/App/Yath/Options.pm create mode 100644 liby/App/Yath/Options/Collector.pm create mode 100644 liby/App/Yath/Options/Debug.pm create mode 100644 liby/App/Yath/Options/Display.pm create mode 100644 liby/App/Yath/Options/Finder.pm create mode 100644 liby/App/Yath/Options/Logging.pm create mode 100644 liby/App/Yath/Options/Persist.pm create mode 100644 liby/App/Yath/Options/PreCommand.pm create mode 100644 liby/App/Yath/Options/Run.pm create mode 100644 liby/App/Yath/Options/Runner.pm create mode 100644 liby/App/Yath/Options/Workspace.pm create mode 100644 liby/App/Yath/Plugin.pm create mode 100644 liby/App/Yath/Plugin/Cover.pm create mode 100644 liby/App/Yath/Plugin/Git.pm create mode 100644 liby/App/Yath/Plugin/Notify.pm create mode 100644 liby/App/Yath/Plugin/SysInfo.pm create mode 100644 liby/App/Yath/Plugin/YathUI.pm create mode 100644 liby/App/Yath/Tester.pm create mode 100644 liby/App/Yath/Util.pm create mode 100644 liby/Test2/Formatter/QVF.pm create mode 100644 liby/Test2/Formatter/Stream.pm create mode 100644 liby/Test2/Formatter/Test2.pm create mode 100644 liby/Test2/Formatter/Test2/Composer.pm create mode 100644 liby/Test2/Harness.pm create mode 100644 liby/Test2/Harness/Aggregator.pm create mode 100644 liby/Test2/Harness/Auditor.pm create mode 100644 liby/Test2/Harness/Auditor/TimeTracker.pm create mode 100644 liby/Test2/Harness/Auditor/Watcher.pm create mode 100644 liby/Test2/Harness/Collector.pm create mode 100644 liby/Test2/Harness/Collector/JobDir.pm create mode 100644 liby/Test2/Harness/Collector/TapParser.pm create mode 100644 liby/Test2/Harness/Event.pm create mode 100644 liby/Test2/Harness/Finder.pm create mode 100644 liby/Test2/Harness/IPC.pm create mode 100644 liby/Test2/Harness/IPC/Model.pm create mode 100644 liby/Test2/Harness/IPC/Model/AtomicPipe.pm create mode 100644 liby/Test2/Harness/IPC/Model/FilePipeHybrid.pm create mode 100644 liby/Test2/Harness/IPC/Model/Files.pm create mode 100644 liby/Test2/Harness/IPC/Process.pm create mode 100644 liby/Test2/Harness/IPC/SharedState.pm create mode 100644 liby/Test2/Harness/Log.pm create mode 100644 liby/Test2/Harness/Log/CoverageAggregator.pm create mode 100644 liby/Test2/Harness/Log/CoverageAggregator/ByRun.pm create mode 100644 liby/Test2/Harness/Log/CoverageAggregator/ByTest.pm create mode 100644 liby/Test2/Harness/Plugin.pm create mode 100644 liby/Test2/Harness/Renderer.pm create mode 100644 liby/Test2/Harness/Renderer/Formatter.pm create mode 100644 liby/Test2/Harness/Run.pm create mode 100644 liby/Test2/Harness/Runner.pm create mode 100644 liby/Test2/Harness/Runner/Constants.pm create mode 100644 liby/Test2/Harness/Runner/DepTracer.pm create mode 100644 liby/Test2/Harness/Runner/Job.pm create mode 100644 liby/Test2/Harness/Runner/Preload.pm create mode 100644 liby/Test2/Harness/Runner/Preload/Stage.pm create mode 100644 liby/Test2/Harness/Runner/Preloader.pm create mode 100644 liby/Test2/Harness/Runner/Preloader/Stage.pm create mode 100644 liby/Test2/Harness/Runner/Reloader.pm create mode 100644 liby/Test2/Harness/Runner/Resource.pm create mode 100644 liby/Test2/Harness/Runner/Resource/JobCount.pm create mode 100644 liby/Test2/Harness/Runner/Resource/SharedJobSlots.pm create mode 100644 liby/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm create mode 100644 liby/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm create mode 100644 liby/Test2/Harness/Runner/Run.pm create mode 100644 liby/Test2/Harness/Runner/Spawn.pm create mode 100644 liby/Test2/Harness/Runner/State.pm create mode 100644 liby/Test2/Harness/Settings.pm create mode 100644 liby/Test2/Harness/Settings/Prefix.pm create mode 100644 liby/Test2/Harness/State.pm create mode 100644 liby/Test2/Harness/State/Instance.pm create mode 100644 liby/Test2/Harness/TestFile.pm create mode 100644 liby/Test2/Harness/Util.pm create mode 100644 liby/Test2/Harness/Util/Collector.pm create mode 100644 liby/Test2/Harness/Util/Collector.pm2 create mode 100644 liby/Test2/Harness/Util/File.pm create mode 100644 liby/Test2/Harness/Util/File/JSON.pm create mode 100644 liby/Test2/Harness/Util/File/JSONL.pm create mode 100644 liby/Test2/Harness/Util/File/Stream.pm create mode 100644 liby/Test2/Harness/Util/File/Value.pm create mode 100644 liby/Test2/Harness/Util/HashBase.pm create mode 100644 liby/Test2/Harness/Util/IPC.pm create mode 100644 liby/Test2/Harness/Util/JSON.pm create mode 100644 liby/Test2/Harness/Util/Queue.pm create mode 100644 liby/Test2/Harness/Util/Term.pm create mode 100644 liby/Test2/Harness/Util/UUID.pm create mode 100644 liby/Test2/Tools/HarnessTester.pm create mode 100644 moreold/Base.pm create mode 100644 moreold/Shared.pm create mode 100644 moreold/TxnState.pm create mode 100755 scripts/yath-stage create mode 100644 t/acceptence/getopt_yath.t create mode 100644 t/acceptence/ipc_statefile.t create mode 100644 t/fake.t delete mode 100644 t/integration/concurrency.t delete mode 100644 t/integration/concurrency/a.tx delete mode 100644 t/integration/concurrency/b.tx delete mode 100644 t/integration/concurrency/c.tx delete mode 100644 t/integration/concurrency/d.tx delete mode 100644 t/integration/concurrency/e.tx delete mode 100644 t/integration/coverage.t delete mode 100644 t/integration/coverage/a.tx delete mode 100644 t/integration/coverage/b.tx delete mode 100644 t/integration/coverage/c.tx delete mode 100644 t/integration/coverage/lib/Ax.pm delete mode 100644 t/integration/coverage/lib/Bx.pm delete mode 100644 t/integration/coverage/lib/Cx.pm delete mode 100644 t/integration/coverage/lib/Manager.pm delete mode 100644 t/integration/coverage/lib/Plugin.pm delete mode 100644 t/integration/coverage/once.tx delete mode 100644 t/integration/coverage/open.tx delete mode 100644 t/integration/coverage/x.tx delete mode 100644 t/integration/coverage2.t delete mode 100644 t/integration/coverage3.t delete mode 100644 t/integration/coverage4.t delete mode 100644 t/integration/encoding.t delete mode 100644 t/integration/encoding/no-plugin.tx delete mode 100644 t/integration/encoding/plugin.tx delete mode 100644 t/integration/failed.t delete mode 100644 t/integration/failed/fail.tx delete mode 100644 t/integration/failed/pass.tx delete mode 100644 t/integration/failure_cases.t delete mode 100644 t/integration/failure_cases/badplan.tx delete mode 100644 t/integration/failure_cases/buffered_subtest_abrupt_end.tx delete mode 100644 t/integration/failure_cases/buffered_subtest_abrupt_end_nested.tx delete mode 100644 t/integration/failure_cases/dupnums.tx delete mode 100644 t/integration/failure_cases/exit.tx delete mode 100644 t/integration/failure_cases/missingnums.tx delete mode 100644 t/integration/failure_cases/nested_subtest.tx delete mode 100644 t/integration/failure_cases/nested_subtest_exception.tx delete mode 100644 t/integration/failure_cases/noplan.tx delete mode 100644 t/integration/failure_cases/notok.tx delete mode 100644 t/integration/failure_cases/parse_error.tx delete mode 100644 t/integration/failure_cases/post_exit_timeout.tx delete mode 100644 t/integration/failure_cases/subtest.tx delete mode 100644 t/integration/failure_cases/timeout.tx delete mode 100644 t/integration/help.t delete mode 100644 t/integration/includes.t delete mode 100644 t/integration/includes/.yath.rc delete mode 100644 t/integration/includes/default-i.tx delete mode 100644 t/integration/includes/default.tx delete mode 100644 t/integration/includes/dot-last.tx delete mode 100644 t/integration/includes/not-perl.pl delete mode 100755 t/integration/includes/not-perl.sh delete mode 100644 t/integration/includes/order-ibili.tx delete mode 100644 t/integration/includes/order-ilibi.tx delete mode 100644 t/integration/init.t delete mode 100644 t/integration/log_dir.t delete mode 100644 t/integration/log_dir/foo.tx delete mode 100644 t/integration/persist.t delete mode 100644 t/integration/persist/fail.txx delete mode 100644 t/integration/persist/pass.tx delete mode 100644 t/integration/plugin.t delete mode 100644 t/integration/plugin/a.tx delete mode 100644 t/integration/plugin/b.tx delete mode 100644 t/integration/plugin/c.tx delete mode 100644 t/integration/plugin/d.tx delete mode 100644 t/integration/plugin/lib/App/Yath/Plugin/TestPlugin.pm delete mode 100644 t/integration/plugin/test.tx delete mode 100644 t/integration/preload.t delete mode 100644 t/integration/preload/aaa.tx delete mode 100644 t/integration/preload/bbb.tx delete mode 100644 t/integration/preload/ccc.tx delete mode 100644 t/integration/preload/fast.tx delete mode 100644 t/integration/preload/lib/AAA.pm delete mode 100644 t/integration/preload/lib/BBB.pm delete mode 100644 t/integration/preload/lib/Broken.pm delete mode 100644 t/integration/preload/lib/CCC.pm delete mode 100644 t/integration/preload/lib/FAST.pm delete mode 100644 t/integration/preload/lib/TestBadPreload.pm delete mode 100644 t/integration/preload/lib/TestPreload.pm delete mode 100644 t/integration/preload/lib/TestSimplePreload.pm delete mode 100644 t/integration/preload/no_preload.tx delete mode 100644 t/integration/preload/preload_test.tx delete mode 100644 t/integration/preload/retry.tx delete mode 100644 t/integration/preload/simple_test.tx delete mode 100644 t/integration/preload/slow.tx delete mode 100644 t/integration/projects.t delete mode 100644 t/integration/projects/bar/lib/Bar.pm delete mode 100644 t/integration/projects/bar/lib/Baz.pm delete mode 100644 t/integration/projects/bar/lib/Foo.pm delete mode 100644 t/integration/projects/bar/t/pass.tx delete mode 100644 t/integration/projects/baz/lib/Bar.pm delete mode 100644 t/integration/projects/baz/lib/Baz.pm delete mode 100644 t/integration/projects/baz/lib/Foo.pm delete mode 100644 t/integration/projects/baz/t/fail.txx delete mode 100644 t/integration/projects/baz/t/pass.tx delete mode 100644 t/integration/projects/foo/lib/Bar.pm delete mode 100644 t/integration/projects/foo/lib/Baz.pm delete mode 100644 t/integration/projects/foo/lib/Foo.pm delete mode 100644 t/integration/projects/foo/t/pass.tx delete mode 100644 t/integration/reload.t delete mode 100644 t/integration/reload/lib/Preload.pm delete mode 100644 t/integration/reload/lib/Preload/A.pm delete mode 100644 t/integration/reload/lib/Preload/B.pm delete mode 100644 t/integration/reload/lib/Preload/Churn.pm delete mode 100644 t/integration/reload/lib/Preload/ExceptionA.pm delete mode 100644 t/integration/reload/lib/Preload/ExceptionB.pm delete mode 100644 t/integration/reload/lib/Preload/ExporterA.pm delete mode 100644 t/integration/reload/lib/Preload/ExporterB.pm delete mode 100644 t/integration/reload/lib/Preload/IncChange.pm delete mode 100644 t/integration/reload/lib/Preload/WarningA.pm delete mode 100644 t/integration/reload/lib/Preload/WarningB.pm delete mode 100644 t/integration/reload/lib/Preload/nonperl1 delete mode 100644 t/integration/reload/lib/Preload/nonperl2 delete mode 100644 t/integration/reload_syntax_error.t delete mode 100644 t/integration/reload_syntax_error.tx delete mode 100644 t/integration/replay.t delete mode 100644 t/integration/replay/fail.tx delete mode 100644 t/integration/replay/pass.tx delete mode 100644 t/integration/resource.t delete mode 100644 t/integration/resource/Resource.pm delete mode 100644 t/integration/resource/a.tx delete mode 100644 t/integration/resource/b.tx delete mode 100644 t/integration/resource/c.tx delete mode 100644 t/integration/resource/d.tx delete mode 100644 t/integration/retry-symlinks/retry.tx delete mode 120000 t/integration/retry-symlinks/symlink.tl delete mode 100644 t/integration/retry-timeout/retry.tx delete mode 100644 t/integration/retry.t delete mode 100644 t/integration/retry/retry.tx delete mode 100644 t/integration/signals.t delete mode 100644 t/integration/signals/abrt_or_iot.t delete mode 100644 t/integration/slots_per_job.t delete mode 100644 t/integration/slots_per_job2.t delete mode 100644 t/integration/slots_per_job3.t delete mode 100644 t/integration/smoke.t delete mode 100644 t/integration/smoke/a.tx delete mode 100644 t/integration/smoke/b.tx delete mode 100644 t/integration/smoke/c.tx delete mode 100644 t/integration/smoke/d.tx delete mode 100644 t/integration/smoke/e.tx delete mode 100644 t/integration/smoke/f.tx delete mode 100644 t/integration/smoke/g.tx delete mode 100644 t/integration/smoke/h.tx delete mode 100644 t/integration/smoke/lib/SmokePlugin.pm delete mode 100644 t/integration/speedtag.t delete mode 100644 t/integration/speedtag/pass.tx delete mode 100644 t/integration/speedtag/pass2.tx delete mode 100644 t/integration/stamps.t delete mode 100644 t/integration/stamps/fail.tx delete mode 100644 t/integration/stamps/lib/App/Yath/Plugin/TestPlugin.pm delete mode 100644 t/integration/stamps/pass.tx delete mode 100644 t/integration/tapsubtest.t delete mode 100644 t/integration/tapsubtest/test.tx delete mode 100644 t/integration/test-broken-symlinks/keepme delete mode 100644 t/integration/test-broken-symlinks/pass.tx delete mode 100644 t/integration/test-durations.json delete mode 100644 t/integration/test-durations/fast-01.tx delete mode 100644 t/integration/test-durations/fast-02.tx delete mode 100644 t/integration/test-durations/fast-03.tx delete mode 100644 t/integration/test-durations/fast-04.tx delete mode 100644 t/integration/test-durations/slow-01.tx delete mode 100644 t/integration/test-durations/slow-02.tx delete mode 100644 t/integration/test-inc/check-INC.tx delete mode 100644 t/integration/test-symlinks/_base.xt delete mode 120000 t/integration/test-symlinks/symlink_to_base.xt delete mode 100644 t/integration/test.t delete mode 100644 t/integration/test/fail.txx delete mode 100644 t/integration/test/pass.tx delete mode 100644 t/integration/test/pass.txxx delete mode 100644 t/integration/times.t delete mode 100644 t/integration/times/pass.tx delete mode 100644 t/integration/times/pass2.tx delete mode 100644 t/integration/verbose_env.t delete mode 100644 t/integration/verbose_env/not_verbose.tx delete mode 100644 t/integration/verbose_env/verbose1.tx delete mode 100644 t/integration/verbose_env/verbose2.tx delete mode 100644 t/lib/App/Yath/Command/broken.pm delete mode 100644 t/lib/App/Yath/Command/fake.pm delete mode 100644 t/lib/App/Yath/Plugin/Fail.pm delete mode 100644 t/lib/App/Yath/Plugin/Options.pm delete mode 100644 t/unit/App/Yath.t delete mode 100644 t/unit/App/Yath/Command/init.t delete mode 100644 t/unit/App/Yath/Option.t delete mode 100644 t/unit/App/Yath/Options.t delete mode 100644 t/unit/App/Yath/Plugin.t delete mode 100755 t/unit/App/Yath/Plugin/Git.script delete mode 100755 t/unit/App/Yath/Plugin/Git.t delete mode 100644 t/unit/App/Yath/Plugin/SysInfo.t delete mode 100644 t/unit/App/Yath/Util.t delete mode 100644 t/unit/Test2/Harness/Runner/DepTracer.t delete mode 100644 t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/.sharedjobslots.yml delete mode 100644 t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/Config.t delete mode 100644 t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/State.t delete mode 100644 t/unit/Test2/Harness/Settings.t delete mode 100644 t/unit/Test2/Harness/Settings/Prefix.t delete mode 100644 t/unit/Test2/Harness/TestFile.t delete mode 100644 t/unit/Test2/Harness/Util.t delete mode 100644 t/unit/Test2/Harness/Util/File.t delete mode 100644 t/unit/Test2/Harness/Util/File/JSON.t delete mode 100644 t/unit/Test2/Harness/Util/File/JSONL.t delete mode 100644 t/unit/Test2/Harness/Util/File/Stream.t delete mode 100644 t/unit/Test2/Harness/Util/File/Value.t delete mode 100644 t/unit/Test2/Harness/Util/JSON.t delete mode 100644 t/unit/Test2/Harness/Util/Term.t delete mode 100644 t/unit/Test2/Tools/HarnessTester.t create mode 100644 template.pod create mode 100644 templib/XXX.pm create mode 100644 templib/YYY.pm create mode 100644 xt/author/critic.t diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 000000000..aa7d96db2 --- /dev/null +++ b/.perlcriticrc @@ -0,0 +1,13 @@ +color = 1 +include = Variables::ProhibitConditionalDeclarations +exclude = Modules::RequireFilenameMatchesPackage Subroutines::ProhibitSubroutinePrototypes BuiltinFunctions::ProhibitStringyEval InputOutput::RequireEncodingWithUTF8Layer InputOutput::ProhibitInteractiveTest TestingAndDebugging::ProhibitNoStrict TestingAndDebugging::ProhibitNoWarnings ValuesAndExpressions::ProhibitLeadingZeros Subroutines::ProhibitExplicitReturnUndef +criticism-fatal = 1 + +[Variables::ProhibitConditionalDeclarations] +severity = 5 + +[TestingAndDebugging::RequireUseStrict] +equivalent_modules = Test2::V0 + +[TestingAndDebugging::RequireUseWarnings] +equivalent_modules = Test2::V0 diff --git a/.yath.rc b/.yath.rc.xxx similarity index 100% rename from .yath.rc rename to .yath.rc.xxx diff --git a/Debug.pm b/Debug.pm new file mode 100644 index 000000000..825b6fb70 --- /dev/null +++ b/Debug.pm @@ -0,0 +1,339 @@ +package App::Yath::Options::Debug; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries mod2file clean_path/; + +use Errno qw/EINTR/; + +use App::Yath::Options; + +option_group {prefix => 'debug', category => 'Help and Debugging'} => sub { + post 99999 => \&_post_process_show_opts; + post 99998 => \&_post_process_interactive; + post \&_post_process_version; + post \&_post_process_help; + + option dummy => ( + short => 'd', + description => 'Dummy run, do not actually execute anything', + env_vars => [qw/T2_HARNESS_DUMMY/], + clear_env_vars => 1, + default => 0, + ); + + option procname_prefix => ( + type => 's', + default => '', + description => 'Add a prefix to all proc names (as seen by ps).', + ); + + option keep_dirs => ( + short => 'k', + alt => ['keep_dir'], + description => 'Do not delete directories when done. This is useful if you want to inspect the directories used for various commands.', + default => 0, + ); + + option 'show-opts' => ( + description => 'Exit after showing what yath thinks your options mean', + pre_command => 1, + ); + + option version => ( + short => 'V', + description => "Exit after showing a helpful usage message", + pre_command => 1, + ); + + option help => ( + short => 'h', + description => "exit after showing help information", + ); + + option interactive => ( + short => 'i', + description => 'Use interactive mode, 1 test at a time, stdin forwarded to it', + ); + + warn "Move this to rendering"; + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + normalize => \&normalize_summary, + action => \&summary_action, + applicable => sub { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; + }, + ); +}; + +sub normalize_summary { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub summary_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('summary.json'); +} + +sub _post_process_help { + my %params = @_; + + return unless $params{settings}->debug->help; + + my $help; + if (my $cmd = $params{command}) { + $help = $cmd->cli_help(%params); + } + else { + $help = __PACKAGE__->cli_help(%params); + } + + if (eval { require IO::Pager; 1 }) { + local $SIG{PIPE} = sub {}; + my $pager = IO::Pager->new(*STDOUT); + $pager->print($help); + } + else { + print $help; + } + + exit 0; +} + +sub _post_process_show_opts { + my %params = @_; + + return unless $params{settings}->debug->show_opts; + + my $settings = $params{settings}; + + print "\nCommand selected: " . $params{command}->name . " (" . ref($params{command}) . ")\n" if $params{command}; + + my $args = $params{args}; + print "\nCommand args: " . join(', ' => @$args) . "\n" if @$args; + + my $out = encode_pretty_json($settings); + + print "\nCurrent command line and config options result in these settings:\n"; + print "$out\n"; + + exit 0; +} + +my $RAN = 0; +sub _post_process_interactive { + return if $RAN++; + my %params = @_; + + return unless $params{settings}->debug->interactive; + + my $settings = $params{settings}; + + my ($fifo); + if ($settings->check_prefix('workspace')) { + my $dir = $settings->workspace->workdir; + $fifo = "$dir/fifo-$$"; + } + else { + require File::Temp; + my $fh; + ($fh, $fifo) = File::Temp::tempfile("YATH-FIFO-$$-XXXXXX", TMPDIR => 1); + close($fh); + unlink($fifo); + } + + ${$settings->debug->vivify_field('fifo')} = $fifo; + + if ($settings->check_prefix('display')) { + $settings->display->field(quiet => 0); + $settings->display->field(verbose => 1) unless $settings->display->verbose; + } + + if ($settings->check_prefix('formatter')) { + $settings->formatter->field(qvf => 0); + } + + if ($settings->check_prefix('run')) { + $settings->run->env_vars->{YATH_INTERACTIVE} = $fifo; + $ENV{YATH_INTERACTIVE} = $fifo; + } + + my $pid = fork() // die "Could not fork: $!"; + if ($pid) { + require Scope::Guard; + require POSIX; + POSIX::mkfifo($fifo, 0700) or die "Failed to make fifo ($fifo): $!"; + my $fh; + + my $cleanup = sub { + close($fh) if $fh; + unlink($fifo) if -e $fifo; + }; + + my $old_int_handler = $SIG{INT}; + my $old_term_handler = $SIG{TERM}; + + $SIG{INT} = sub { $cleanup->('INT'); $old_int_handler->() if ref $old_int_handler; exit 1; }; + $SIG{TERM} = sub { $cleanup->('TERM'); $old_term_handler->() if ref $old_term_handler; exit 1; }; + $SIG{PIPE} = sub { exit 1 }; + + $SIG{CHLD} = sub { + my $res = waitpid($pid, 0); + my $exit = ($? >> 8); + + close($fh) if $fh; + unlink($fifo) if -e $fifo; + + # Forward the exit code from our child + exit($exit); + }; + + for (1 .. 10) { + last if open($fh, '>', $fifo); + die "Could not open fifo ($fifo): $!" unless $! == EINTR; + sleep 1; + } + die "Could not open fifo ($fifo): $!" unless $fh; + + $fh->autoflush(1); + my $guard = Scope::Guard->new($cleanup); + + while(1) { + my $data = ; + if (defined($data) && length($data)) { + print $fh $data; + next; + } + + next if defined($data); + + next if kill(0, $pid); + print STDERR "Lost child process $pid\n"; + $cleanup->(); + exit 255; + } + } + + close(STDIN); + open(STDIN, '<', '/dev/null'); + + require Time::HiRes; + while (! -e $fifo) { Time::HiRes::sleep(0.1) }; +} + +sub _post_process_version { + my %params = @_; + + return unless $params{settings}->debug->version; + + require App::Yath; + my $out = <<" EOT"; + +Yath version: $App::Yath::VERSION + +Extended Version Info + EOT + + my $plugin_libs = find_libraries('App::Yath::Plugin::*'); + + my @vers = ( + [perl => $^V], + ['App::Yath' => App::Yath->VERSION], + ( + map { + eval { require(mod2file($_)); 1 } + ? [$_ => $_->VERSION // 'N/A'] + : [$_ => 'N/A'] + } qw/Test2::API Test2::Suite Test::Builder/ + ), + ( + map { + eval { require($plugin_libs->{$_}); 1 } + && [$_ => $_->VERSION // 'N/A'] + } sort keys %$plugin_libs + ), + ); + + $out .= join "\n" => table( + header => [qw/COMPONENT VERSION/], + rows => \@vers, + ); + + print "$out\n\n"; + + exit 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Debug - Debug options for Yath + +=head1 DESCRIPTION + +This is where debug related command line options live. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Workspace.pm b/Workspace.pm new file mode 100644 index 000000000..dd83befca --- /dev/null +++ b/Workspace.pm @@ -0,0 +1,64 @@ +package App::Yath::Options::Workspace; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use File::Spec(); +use File::Path qw/remove_tree/; +use File::Temp qw/tempdir/; + +use Test2::Harness::Util qw/clean_path chmod_tmp/; + +use App::Yath::Options; + +option_group {prefix => 'workspace', category => "Workspace Options"} => sub { +}; + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Workspace - Options for specifying the yath work dir. + +=head1 DESCRIPTION + +Options regarding the yath working directory. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/bad/App/Yath.pm b/bad/App/Yath.pm new file mode 100644 index 000000000..2d38ff012 --- /dev/null +++ b/bad/App/Yath.pm @@ -0,0 +1,879 @@ +package App::Yath; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw{ + -config + -settings + + -_options -options_loaded + -_argv -argv_processed <_orig_argv + + -_command_class -_command_name -_early_command +}; + +use Time::HiRes qw/time/; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/find_libraries clean_path/; +use App::Yath::Options(); +use Scalar::Util qw/blessed/; + +my $APP_PATH = __FILE__; +$APP_PATH =~ s{App\S+Yath\.pm$}{}g; +$APP_PATH = clean_path($APP_PATH); +sub app_path { $APP_PATH } + +sub init { + my $self = shift; + + my $old = select STDOUT; + $| = 1; + select STDERR; + $| = 1; + select $old; + + my @caller = caller(1); + + $self->{+SETTINGS} //= Test2::Harness::Settings->new; + + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('script')} //= clean_path($caller[1]); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('start')} //= time(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('no_scan_plugins')} //= 0; + + $self->{+_ARGV} //= delete($self->{argv}) // []; + $self->{+_ORIG_ARGV} = [@{$self->{+_ARGV}}]; + $self->{+CONFIG} //= {}; +} + +sub generate_run_sub { + my $self = shift; + my ($symbol) = @_; + + my $cmd_class; + my ($options, $argv); + + if (my $cmd = $self->_command_from_argv(no_default => 1, valid_only => 1)) { + $cmd_class = $self->load_command($cmd); + + $self->{+_COMMAND_NAME} = $cmd; + $self->{+_COMMAND_CLASS} = $cmd_class; + + if ($cmd_class->only_cmd_opts) { + $self->{+_EARLY_COMMAND} = 1; + my $settings = $self->{+SETTINGS}; + + $options = App::Yath::Options->new(settings => $settings); + $options->set_command_class($cmd_class); + $options->set_args($self->{+_ARGV}); + + $argv = $self->{+_ARGV}; + $cmd_class->munge_opts($options, $argv, $settings); + } + } + + $options //= $self->load_options(); + + $cmd_class //= $self->command_class(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('command')} //= $cmd_class; + + $argv = $self->process_argv(); + + return $cmd_class->generate_run_sub($symbol, $argv, $self->{+SETTINGS}, $self->{+_ORIG_ARGV}) if $cmd_class->can('generate_run_sub'); + + my $cmd = $cmd_class->new(settings => $options->settings, args => $argv, orig_args => $self->{+_ORIG_ARGV}); + + $options->process_option_post_actions($cmd); + + my $run = sub { $self->run_command($cmd) }; + + { + no strict 'refs'; + *{$symbol} = $run; + } + + return; +} + +sub run_command { + my $self = shift; + my ($cmd) = @_; + + my $exit = $cmd->run; + + die "Command '" . $cmd->name() . "' did not return an exit value.\n" + unless defined $exit; + + return $exit; +} + +sub load_options { + my $self = shift; + + my $settings = $self->{+SETTINGS} = $self->{+SETTINGS}; + + my $options = $self->{+_OPTIONS} //= App::Yath::Options->new(settings => $settings); + + return $options if $self->{+OPTIONS_LOADED}++; + + $options->include_from( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ); + + return $options if $self->{+SETTINGS}->harness->no_scan_plugins; + + my $option_libs = { + %{find_libraries('App::Yath::Plugin::*')}, + %{find_libraries('Test2::Harness::Runner::Resource::*')}, + }; + for my $lib (sort keys %$option_libs) { + my $ok = eval { require $option_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load module '$option_libs->{$lib}': $@"; + next; + } + + next unless $lib->can('options'); + my $add = $lib->options; + next unless $add; + + unless (blessed($add) && $add->isa('App::Yath::Options')) { + warn "Module '$option_libs->{$lib}' is outdated, not loading options.\n" + unless $ENV{'YATH_SELF_TEST'}; + next; + } + + $options->include_from($lib); + } + + return $options; +} + +sub process_argv { + my $self = shift; + + return $self->{+_ARGV} if $self->{+ARGV_PROCESSED}++; + + my $options = $self->load_options(); + my $settings = $self->settings; + + my $config_pre_args = $self->{+CONFIG}->{'~'}; + $options->grab_pre_command_opts(args => $config_pre_args, stop_at_non_opt => 0, passthrough => 0, die_at_non_opt => 1) + if $config_pre_args; + + $options->set_args($self->{+_ARGV}); + $options->grab_pre_command_opts(); + + $options->process_pre_command_opts(); + + my $cmd_name = $self->_command_from_argv(); + my $cmd_class = $self->load_command($cmd_name); + die "Command '$cmd_name' needs to be specified earlier in the command line arguments to yath.\n" if $cmd_class->only_cmd_opts && !$self->{+_EARLY_COMMAND}; + $options->set_command_class($cmd_class); + $self->{+_COMMAND_CLASS} = $cmd_class; + + $options->grab_pre_command_opts(stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0); + + my $config_cmd_args = $self->{+CONFIG}->{$cmd_name}; + + $options->grab_pre_command_opts(args => $config_cmd_args, stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0) + if $config_cmd_args; + + $options->process_pre_command_opts(); + + $options->grab_command_opts(args => $config_cmd_args, die_at_non_opt => 1, stop_at_non_opt => 0, passthrough => 0) + if $config_cmd_args; + + $options->grab_command_opts(); + $options->process_command_opts(); + + $options->clear_env(); + + $self->clear_env(); + + my %seen = map {((ref($_) || $_) => 1)} @{$settings->harness->plugins}; + for my $plugin (@{$options->used_plugins}) { + next if $seen{$plugin}++; + push @{$settings->harness->plugins} => $plugin->can('new') ? $plugin->new() : $plugin; + } + + return $self->{+_ARGV}; +} + +sub clear_env { + delete $ENV{HARNESS_IS_VERBOSE}; + delete $ENV{T2_FORMATTER}; + delete $ENV{T2_HARNESS_FORKED}; + delete $ENV{T2_HARNESS_IS_VERBOSE}; + delete $ENV{T2_HARNESS_JOB_IS_TRY}; + delete $ENV{T2_HARNESS_JOB_NAME}; + delete $ENV{T2_HARNESS_PRELOAD}; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_FILE}; + delete $ENV{T2_STREAM_JOB_ID}; + delete $ENV{TEST2_JOB_DIR}; + delete $ENV{TEST2_RUN_DIR}; + + # If Test2::API is already loaded then we need to keep these. + delete $ENV{TEST2_ACTIVE} unless $INC{'Test2/API.pm'}; + delete $ENV{TEST_ACTIVE} unless $INC{'Test2/API.pm'}; +} + +sub command_class { + my $self = shift; + + $self->process_argv() unless $self->{+_COMMAND_CLASS}; + + return $self->{+_COMMAND_CLASS}; +} + +sub _command_from_argv { + my $self = shift; + my %params = @_; + + return $self->{+_COMMAND_NAME} if $self->{+_COMMAND_NAME}; + + my $argv = $self->{+_ARGV}; + + for (my $idx = 0; $idx < @$argv; $idx++) { + my $arg = $argv->[$idx]; + + if ($arg =~ m/^-*h(elp)?$/i) { + splice(@$argv, $idx, 1); + return 'help'; + } + + if ($arg eq 'do') { + splice(@$argv, $idx, 1); + last; + } + + last if $arg eq '::'; + next if $arg =~ /^-/; + + if ($arg =~ m/\.jsonl(\.bz2|\.gz)?$/) { + warn "\n** First argument is a log file, defaulting to the 'replay' command **\n\n"; + return 'replay'; + } + + return splice(@$argv, $idx, 1) if $self->load_command($arg, check_only => 1); + return if $params{valid_only}; + + my $is_path = 0; + $is_path ||= -f $arg; + $is_path ||= -d $arg; + + # Assume it is a command, but an invalid one. + return splice(@$argv, $idx, 1) unless $is_path; + } + + return if $params{no_default}; + + if (my $pfile = find_pfile($self->settings, no_checks => 1)) { + warn "\n** Persistent runner detected, defaulting to the 'run' command **\n\n"; + return 'run'; + } + + warn "\n** Defaulting to the 'test' command **\n\n"; + return 'test'; +} + +sub load_command { + my $self = shift; + my ($cmd_name, %params) = @_; + + my $cmd_class = "App::Yath::Command::$cmd_name"; + my $cmd_file = "App/Yath/Command/$cmd_name.pm"; + + return $cmd_class if eval { require $cmd_file; 1 }; + my $error = $@ || 'unknown error'; + + my $not_found = $error =~ m{Can't locate \Q$cmd_file\E in \@INC}; + + return undef if $params{check_only} && $not_found; + + die "yath command '$cmd_name' not found. (did you forget to install $cmd_class?)\n" + if $not_found; + + die $error; +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath - Yet Another Test Harness (Test2-Harness) Command Line Interface +(CLI) + +=head1 DESCRIPTION + +This is the primary documentation for C, L, L. + +The canonical source of up-to-date command options are the help output when +using C<$ yath help> and C<$ yath help COMMAND>. + +This document is mainly an overview of C usage and common recipes. + +L is an alternative to L, and L is an alternative to L. It is not designed to +replace L/prove. L is designed to take full +advantage of the rich data L can provide. L is also able to +use non-core modules and provide more functionality than prove can achieve with +its restrictions. + +=head1 PLATFORM SUPPORT + +L/L is is focused on unix-like platforms. Most +development happens on linux, but bsd, macos, etc should work fine as well. + +Patches are welcome for any/all platforms, but the primary author (Chad +'Exodist' Granum) does not directly develop against non-unix platforms. + +=head2 WINDOWS + +Currently windows is not supported, and it is known that the package will not +install on windows. Patches are be welcome, and it would be great if someone +wanted to take on the windows-support role, but it is not a primary goal for +the project. + +=head1 OVERVIEW + +To use L, you use the C command. Yath will find the tests +(or use the ones you specify) and run them. As it runs, it will output +diagnostic information such as failures. At the end, yath will print a summary +of the test run. + +C can be thought of as a more powerful alternative to C +(L) + +=head1 RECIPES + +These are common recipes for using C. + +=head2 RUN PROJECT TESTS + + $ yath + +Simply running yath with no arguments means "Run all tests for the current +project". Yath will look for tests in C<./t>, C<./t2>, and C<./test.pl> and +run any which are found. + +Normally this implies the C command but will instead imply the C +command if a persistent test runner is detected. + +=head2 PRELOAD MODULES + +Yath has the ability to preload modules. Yath normally forks to start new +tests, so preloading can reduce the time spent loading modules over and over in +each test. + +Note that some tests may depend on certain modules not being loaded. In these +cases you can add the C<# HARNESS-NO-PRELOAD> directive to the top of the test +files that cannot use preload. + +=head3 SIMPLE PRELOAD + +Any module can be preloaded: + + $ yath -PMoose + +You can preload as many modules as you want: + + $ yath -PList::Util -PScalar::Util + +=head3 COMPLEX PRELOAD + +If your preload is a subclass of L then more +complex preload behavior is possible. See those docs for more info. + +=head2 LOGGING + +=head3 RECORDING A LOG + +You can turn on logging with a flag. The filename of the log will be printed at +the end. + + $ yath -L + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl + +The event log can be quite large. It can be compressed with bzip2. + + $ yath -B + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +gzip compression is also supported. + + $ yath -G + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.gz + +C<-B> and C<-G> both imply C<-L>. + +=head3 REPLAYING FROM A LOG + +You can replay a test run from a log file: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +This will be significantly faster than the initial run as no tests are actually +being executed. All events are simply read from the log, and processed by the +harness. + +You can change display options and limit rendering/processing to specific test +jobs from the run: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 -v [TEST UUID(S)] + +Note: This is done using the C<$ yath replay ...> command. The C +command is implied if the first argument is a log file. + +=head2 PER-TEST TIMING DATA + +The C<-T> option will cause each test file to report how long it took to run. + + $ yath -T + + ( PASSED ) job 1 t/yath_script.t + ( TIME ) job 1 Startup: 0.07692s | Events: 0.01170s | Cleanup: 0.00190s | Total: 0.09052s + +=head2 PERSISTENT RUNNER + +yath supports starting a yath session that waits for tests to run. This is very +useful when combined with preload. + +=head3 STARTING + +This starts the server. Many options available to the 'test' command will work +here but not all. See C<$ yath help start> for more info. + + $ yath start + +=head3 RUNNING + +This will run tests using the persistent runner. By default, it will search for +tests just like the 'test' command. Many options available to the C +command will work for this as well. See C<$ yath help run> for more details. + + $ yath run + +=head3 STOPPING + +Stopping a persistent runner is easy. + + $ yath stop + +=head3 INFORMATIONAL + +The C command will tell you which persistent runner will be used. Yath +searches for the persistent runner in the current directory, then searches in +parent directories until it either hits the root directory, or finds the +persistent runner tracking file. + + $ yath which + +The C command will tail the runner's log files. + + $ yath watch + +=head3 PRELOAD + PERSISTENT RUNNER + +You can use preloads with the C command. In this case, yath will +track all the modules pulled in during preload. If any of them change, the +server will reload itself to bring in the changes. Further, modified modules +will be blacklisted so that they are not preloaded on subsequent reloads. This +behavior is useful if you are actively working on a module that is normally +preloaded. + +=head2 MAKING YOUR PROJECT ALWAYS USE YATH + + $ yath init + +The above command will create C. C is automatically run by +most build utils, in which case only the exit value matters. The generated +C will run C and execute all tests in the C<./t> and/or C<./t2> +directories. Tests in C<./t> will ALSO be run by prove but tests in C<./t2> +will only be run by yath. + +=head2 PROJECT-SPECIFIC YATH CONFIG + +You can write a C<.yath.rc> file. The file format is very simple. Create a +C<[COMMAND]> section to start the configuration for a command and then +provide any options normally allowed by it. When C is run inside your +project, it will use the config specified in the rc file, unless overridden +by command line options. + +B You can also add pre-command options by placing them at the top of +your config file I any C<[cmd]> markers. + +Comments start with a semi-colon. + +Example .yath.rc: + + -pFoo ; Load the 'foo' plugin before dealing with commands. + + [test] + -B ;Always write a bzip2-compressed log + + [start] + -PMoose ;Always preload Moose with a persistent runner + +This file is normally committed into the project's repo. + +=head3 SPECIAL PATH PSEUDO-FUNCTIONS + +Sometimes you want to specify files relative to the .yath.rc so that the config +option works from any subdirectory of the project. Other times you may wish to +use a shell expansion. Sometimes you want both! + +=over 4 + +=item rel(path/to/file) + + -I rel(path/to/extra_lib) + -I=rel(path/to/extra_lib) + +This will take the path to C<.yath.rc> and prefix it to the path inside +C. If for example you have C then the path would +become C. + +=item glob(path/*/file) + + --default-search glob(subprojects/*/t) + --default-search=glob(subprojects/*/t) + +This will add a C<--default-search $_> for every item found in the glob. This +uses the perl builtin function C under the hood. + +=item relglob(path/*/file) + + --default-search relglob(subprojects/*/t) + --default-search=relglob(subprojects/*/t) + +Same as C except paths are relative to the C<.yath.rc> file. + +=back + +=head2 PROJECT-SPECIFIC YATH CONFIG USER OVERRIDES + +You can add a C<.yath.user.rc> file. Format is the same as the regular +C<.yath.rc> file. This file will be read in addition to the regular config +file. Directives in this file will come AFTER the directives in the primary +config so it may be used to override config. + +This file should not normally be committed to the project repo. + +=head2 HARNESS DIRECTIVES INSIDE TESTS + +C will recognise a number of directive comments placed near the top of +test files. These directives should be placed after the C<#!> line but +before any real code. + +Real code is defined as any line that does not start with use, require, BEGIN, package, or # + +=over 4 + +=item good example 1 + + #!/usr/bin/perl + # HARNESS-NO-FORK + + ... + +=item good example 2 + + #!/usr/bin/perl + use strict; + use warnings; + + # HARNESS-NO-FORK + + ... + +=item bad example 1 + + #!/usr/bin/perl + + # blah + + # HARNESS-NO-FORK + + ... + +=item bad example 2 + + #!/usr/bin/perl + + print "hi\n"; + + # HARNESS-NO-FORK + + ... + +=back + +=head3 HARNESS-NO-PRELOAD + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + +Use this if your test will fail when modules are preloaded. This will tell yath +to start a new perl process to run the script instead of forking with preloaded +modules. + +Currently this implies HARNESS-NO-FORK, but that may not always be the case. + +=head3 HARNESS-NO-FORK + + #!/usr/bin/perl + # HARNESS-NO-FORK + +Use this if your test file cannot run in a forked process, but instead must be +run directly with a new perl process. + +This implies HARNESS-NO-PRELOAD. + +=head3 HARNESS-NO-STREAM + +C usually uses the L formatter instead of TAP. +Some tests depend on using a TAP formatter. This option will make C use +L or L. + +=head3 HARNESS-NO-IO-EVENTS + +C can be configured to use the L plugin. This +plugin replaces STDERR and STDOUT in your test with tied handles that fire off +proper L's when they are printed to. Most of the time this is not +an issue, but any fancy tests or modules which do anything with STDERR or +STDOUT other than print may have really messy errors. + +B This plugin is disabled by default, so you only need this directive if +you enable it globally but need to turn it back off for select tests. + +=head3 HARNESS-NO-TIMEOUT + +C will usually kill a test if no events occur within a timeout (default +60 seconds). You can add this directive to tests that are expected to trip the +timeout, but should be allowed to continue. + +NOTE: you usually are doing the wrong thing if you need to set this. See: +C. + +=head3 HARNESS-TIMEOUT-EVENT 60 + +C can be told to alter the default event timeout from 60 seconds to another +value. This is the recommended alternative to HARNESS-NO-TIMEOUT + +=head3 HARNESS-TIMEOUT-POSTEXIT 15 + +C can be told to alter the default POSTEXIT timeout from 15 seconds to another value. + +Sometimes a test will fork producing output in the child while the parent is +allowed to exit. In these cases we cannot rely on the original process exit to +tell us when a test is complete. In cases where we have an exit, and partial +output (assertions with no final plan, or a plan that has not been completed) +we wait for a timeout period to see if any additional events come into + +=head3 HARNESS-DURATION-LONG + +This lets you tell C that the test file is long-running. This is +primarily used when concurrency is turned on in order to run longer tests +earlier, and concurrently with shorter ones. There is also a C option to +skip all long tests. + +This duration is set automatically if HARNESS-NO-TIMEOUT is set. + +=head3 HARNESS-DURATION-MEDIUM + +This lets you tell C that the test is medium. + +This is the default duration. + +=head3 HARNESS-DURATION-SHORT + +This lets you tell C That the test is short. + +=head3 HARNESS-CATEGORY-ISOLATION + +This lets you tell C that the test cannot be run concurrently with other +tests. Yath will hold off and run these tests one at a time after all other +tests. + +=head3 HARNESS-CATEGORY-IMMISCIBLE + +This lets you tell C that the test cannot be run concurrently with other +tests of this class. This is helpful when you have multiple tests which would +otherwise have to be run sequentially at the end of the run. + +Yath prioritizes running these tests above HARNESS-CATEGORY-LONG. + +=head3 HARNESS-CATEGORY-GENERAL + +This is the default category. + +=head3 HARNESS-CONFLICTS-XXX + +This lets you tell C that no other test of type XXX can be run at the +same time as this one. You are able to set multiple conflict types and C +will honor them. + +XXX can be replaced with any type of your choosing. + +NOTE: This directive does not alter the category of your test. You are free +to mark the test with LONG or MEDIUM in addition to this marker. + +=head3 HARNESS-JOB-SLOTS 2 + +=head3 HARNESS-JOB-SLOTS 1 10 + +Specify a range of job slots needed for the test to run. If set to a single +value then the test will only run if it can have the specified number of slots. +If given a range the test will require at least the lower number of slots, and +use up to the maximum number of slots. + +=over 4 + +=item Example with multiple lines. + + #!/usr/bin/perl + # DASH and space are split the same way. + # HARNESS-CONFLICTS-DAEMON + # HARNESS-CONFLICTS MYSQL + + ... + +=item Or on a single line. + + #!/usr/bin/perl + # HARNESS-CONFLICTS DAEMON MYSQL + + ... + +=back + +=head3 HARNESS-RETRY-n + +This lets you specify a number (minimum n=1) of retries on test failure +for a specific test. HARNESS-RETRY-1 means a failing test will be run twice +and is equivalent to HARNESS-RETRY. + +=head3 HARNESS-NO-RETRY + +Use this to avoid this test being retried regardless of your retry settings. + +=head1 MODULE DOCS + +This section documents the L module itself. + +=head2 SYNOPSIS + +In practice you should never need to write your own yath script, or construct +an L instance, or even access themain instance when yath is running. +However some aspects of doing so are documented here for completeness. + +A minimum yath script looks like this: + + BEGIN { + package App::Yath:Script; + + require Time::HiRes; + require App::Yath; + require Test2::Harness::Settings; + + my $settings = Test2::Harness::Settings->new( + harness => { + orig_argv => [@ARGV], + orig_inc => [@INC], + script => __FILE__, + start => Time::HiRes::time(), + version => $App::Yath::VERSION, + }, + ); + + my $app = App::Yath->new( + argv => \@ARGV, + config => {}, + settings => $settings, + ); + + $app->generate_run_sub('App::Yath::Script::run'); + } + + exit(App::Yath::Script::run()); + +It is important that most logic live in a BEGIN block. This is so that +L can be used post-fork to execute a test script. + +The actual yath script is significantly more complicated with the following behaviors: + +=over 4 + +=item pre-process essential arguments such as -D and no-scan-plugins + +=item re-exec with a different yath script if in developer mode and a local copy is found + +=item Parse the yath-rc config files + +=item gather and store essential startup information + +=back + +=head2 METHODS + +App::Yath does not provide many methods to use externally. + +=over 4 + +=item $app->generate_run_sub($symbol_name) + +This tells App::Yath to generate a subroutine at the specified symbol name +which can be run and be expected to return an exit value. + +=item $lib_path = $app->app_path() + +Get the include directory App::Yath was loaded from. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/bad/App/Yath/Command.pm b/bad/App/Yath/Command.pm new file mode 100644 index 000000000..4f49190af --- /dev/null +++ b/bad/App/Yath/Command.pm @@ -0,0 +1,383 @@ +package App::Yath::Command; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Carp qw/croak/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::HashBase qw/-settings -args/; + +use App::Yath::Options(); + +use Test2::Harness::Util::File::JSON(); + +sub internal_only { 0 } +sub always_keep_dir { 0 } +sub summary { "No Summary" } +sub description { "No Description" } +sub group { "Z-UNFINISHED" } +sub doc_args { () } +sub only_cmd_opts { 0 } + +sub handle_invalid_option { 0 } + +sub munge_opts { } + +sub name { $_[0] =~ m/([^:=]+)(?:=.*)?$/; $1 || $_[0] } + +sub run { + my $self = shift; + + warn "This command is currently empty"; + + return 1; +} + +sub cli_help { + my $class = shift; + my %params = @_; + + my $settings = $params{settings} // {}; + my $script = $settings->harness->script // $0; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = $params{options}; + unless ($options) { + $options = App::Yath::Options->new; + $options->set_command_class($class); + } + + my ($pre_opts, $cmd_opts); + if ($options) { + $pre_opts = $options->pre_docs('cli'); + $cmd_opts = $options->cmd_docs('cli'); + } + + my $usage = "Usage: $script"; + + my @out; + + if ($pre_opts) { + $usage .= ' [YATH OPTIONS]'; + + $pre_opts =~ s/^/ /mg; + push @out => "[YATH OPTIONS]\n$pre_opts"; + } + + $usage .= " $cmd"; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + + $cmd_opts =~ s/^/ /mg; + push @out => "[COMMAND OPTIONS]\n$cmd_opts"; + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + my @desc; + for my $arg (@args) { + if (ref($arg)) { + my ($name, $text) = @$arg; + push @desc => $name; + $text =~ s/^/ /mg; + push @desc => "$text\n"; + } + else { + push @desc => "$arg\n"; + } + } + + my $desc = join "\n" => @desc; + $desc =~ s/^/ /mg; + + push @out => "[COMMAND ARGUMENTS]\n$desc"; + } + + chomp(my $desc = $class->description); + unshift @out => ("$cmd - " . $class->summary, $desc, $usage); + + return join("\n\n" => grep { $_ } @out) . "\n"; +} + +sub generate_pod { + my $class = shift; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = App::Yath::Options->new(); + require App::Yath; + my $ay = App::Yath->new(); + $options->include($ay->load_options); + $options->set_command_class($class); + my $pre_opts = $options->pre_docs('pod', 3); + my $cmd_opts = $options->cmd_docs('pod', 3); + + my $usage = " \$ yath [YATH OPTIONS] $cmd"; + + my @head2s; + + push @head2s => ("=head2 YATH OPTIONS", $pre_opts) if $pre_opts; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + push @head2s => ("=head2 COMMAND OPTIONS", $cmd_opts); + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + push @head2s => ( + "=head2 COMMAND ARGUMENTS", + "=over 4", + (map { ref($_) ? ( "=item $_->[0]", $_->[1] ) : ("=item $_") } @args), + "=back" + ); + } + + my @out = ( + "=head1 NAME", + "$class - " . $class->summary, + "=head1 DESCRIPTION", + $class->description, + "=head1 USAGE", + $usage, + @head2s + ); + + return join("\n\n" => grep { $_ } @out); +} + +sub setup_resources { + my $self = shift; + my $settings = $self->settings; + + return unless $settings->check_prefix('runner'); + my $runner = $settings->runner; + my $res = $runner->resources or return; + return unless @$res; + + for my $res (@$res) { + require(mod2file($res)) unless ref $res; + $res->setup($settings); + } +} + +sub setup_plugins { + my $self = shift; + $_->setup($self->settings) for @{$self->settings->harness->plugins}; +} + +sub teardown_plugins { + my $self = shift; + my ($renderers, $logger) = @_; + $_->teardown($self->settings, $renderers, $logger) for @{$self->settings->harness->plugins}; +} + +sub finalize_plugins { + my $self = shift; + $_->finalize($self->settings) for @{$self->settings->harness->plugins}; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Command - Base class for yath commands + +=head1 DESCRIPTION + +This is the base class for any/all yath commands. If you wish to add a new yath +command you should subclass this package. + +=head1 SYNOPSIS + + package App::Yath::Command::mycommand; + use strict; + use warnings; + + use App::Yath::Options(); + use parent 'App::Yath::Command'; + + # Include existing option sets + include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ..., + ); + + # Add some custom options + option_group {prefix => 'mycommand', category => 'mycommand options'} => sub { + option foo => ( + description => "the foo option", + default => 0, + ); + }; + + # This is used to sort/group commands in the "yath help" output + sub group { 'thirdparty' } + + # Brief 1-line summary + sub summary { "This is a third party command, it does stuff..." } + + # Longer description of the command (used in yath help mycommand) + sub description { + return <<" EOT"; + This command does: + This + That + Those + EOT + } + + # Entrypoint + sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + print "Hello Third Party!\n" + + # Return an exit value. + return 0; + } + +=head1 CLASS METHODS + +=over 4 + +=item $string = $cmd_class->cli_help(settings => $settings, options => $options) + +This method generates the command line help for any given command. In general +you will NOT want to override this. + +$settings should be an instance of L. + +$options should be an instance of L if provided. This +method is usually capable of filling in the details when this is omitted. + +=item $multi_line_string = $cmd_class->description() + +Long-form description of the command. Used in C. + +=item @list = $cmd_class->doc_args() + +A list of argument names to the command, used to generate documentation. + +=item $string = $cmd_class->generate_pod() + +This can be used to generate POD documentation from the command itself using +the other fields listed in this section, as well as all applicable command +lines options specified in the command. + +=item $string = $cmd_class->group() + +Used for sorting/grouping commands in the C output. + +Existing groups: + + ' test' # Space in front to make sure test related command float up + 'log' # Log processing commands + 'persist' # Commands related to the persistent runner + 'zinit' # The init command and related command sink to the bottom. + +Unless your command OBVIOUSLY and CLEARLY belongs in one of the above groups +you should probably create your own. Please do not prefix it with a space to +make it float, C<' test'> is a special case, you are not that special. + +=item $string = $cmd_class->name() + +Name of the command. By default this is the last part of the package name. You +will probably never want to override this. + +=item $short_string = $cmd_class->summary() + +A short summary of what this command is. + +=back + +=head1 OBJECT METHODS + +=over 4 + +=item $bool = $cmd->always_keep_dir() + +By default the working directory is deleted when yath exits. Some commands such +as L need to keep the directory. Override this +method to return true if your command uses the workdir and needs to keep it. + +=item $arrayref = $cmd->args() + +Get an arrayref of command line arguments B options have been +process/removed. + +=item $bool = $cmd->internal_only() + +Set this to true if you do not want your command to show up in the help output. + +=item $exit_code = $cmd->run() + +This is the main entrypoint for the command. You B override this. This +method should return an exit code. + +=item $settings = $cmd->settings() + +Get the settings as populated by the command line options. + +=item $cmd->write_settings_to($directory, $filename) + +A helper method to write the settings to a specified directory and filename. +File is written as JSON. + +If you are subclassing another command such as L you +may want to override this to a no-op to prevent the settings file from being +written, the L command does this. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/bad/App/Yath/Command/abort.pm b/bad/App/Yath/Command/abort.pm new file mode 100644 index 000000000..349002f9a --- /dev/null +++ b/bad/App/Yath/Command/abort.pm @@ -0,0 +1,68 @@ +package App::Yath::Command::abort; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; +use Term::Table; + +use File::Spec(); + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command::status'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Abort all currently running or queued tests without killing the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will kill all running tests and clear the queue, but will not close the runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + # Get the output from finding the pfile + $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + print "\nTruncating Queue...\n\n"; + $state->truncate; + $state->poll; + + my $running = $state->running_tasks; + for my $task (values %$running) { + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next;; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + + print "\n"; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/auditor.pm b/bad/App/Yath/Command/auditor.pm similarity index 100% rename from lib/App/Yath/Command/auditor.pm rename to bad/App/Yath/Command/auditor.pm diff --git a/bad/App/Yath/Command/collector.pm b/bad/App/Yath/Command/collector.pm new file mode 100644 index 000000000..d4483c0b9 --- /dev/null +++ b/bad/App/Yath/Command/collector.pm @@ -0,0 +1,69 @@ +package App::Yath::Command::collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; + +use App::Yath::Util qw/isolate_stdout/; + +use Test2::Harness::Util::JSON qw/decode_json/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Run; +use Test2::Harness::State; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'collector' } + +sub run { + my $self = shift; + my ($collector_class, $dir, $run_id, $runner_pid, %args) = @{$self->{+ARGS}}; + + my $name = 'yath-collector'; + $name = "$args{procname_prefix}-${name}" if $args{procname_prefix}; + $0 = $name; + + my $fh = isolate_stdout(); + + my $all_state = Test2::Harness::State->new(workdir => $dir); + my $settings = $all_state->settings; + + require(mod2file($collector_class)); + + my $run = Test2::Harness::Run->new(%{decode_json()}); + + my $collector = $collector_class->new( + %args, + settings => $settings, + workdir => $dir, + run_id => $run_id, + runner_pid => $runner_pid, + run => $run, + # as_json may already have the json form of the event cached, if so + # we can avoid doing an extra call to encode_json + action => sub { print $fh defined($_[0]) ? $_[0]->as_json . "\n" : "null\n"; }, + ); + + local $SIG{PIPE} = 'IGNORE'; + my $ok = eval { $collector->process(); 1 }; + my $err = $@; + + eval { print $fh "null\n"; 1 } or warn $@; + + die $err unless $ok; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/do.pm b/bad/App/Yath/Command/do.pm similarity index 100% rename from lib/App/Yath/Command/do.pm rename to bad/App/Yath/Command/do.pm diff --git a/lib/App/Yath/Command/failed.pm b/bad/App/Yath/Command/failed.pm similarity index 100% rename from lib/App/Yath/Command/failed.pm rename to bad/App/Yath/Command/failed.pm diff --git a/bad/App/Yath/Command/help.pm b/bad/App/Yath/Command/help.pm new file mode 100644 index 000000000..ff1224c98 --- /dev/null +++ b/bad/App/Yath/Command/help.pm @@ -0,0 +1,96 @@ +package App::Yath::Command::help; +use strict; +use warnings; + +use Test2::Util qw/pkg_to_file/; + +our $VERSION = '1.000152'; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/<_command_info_hash/; + +use Test2::Harness::Util qw/open_file find_libraries/; +use List::Util (); + +sub options {}; +sub group { '' } +sub summary { 'Show the list of commands' } + +sub description { + return <<" EOT" +This command provides a list of commands when called with no arguments. +When given a command name as an argument it will print the help for that +command. + EOT +} + +sub command_info_hash { + my $self = shift; + + return $self->{+_COMMAND_INFO_HASH} if $self->{+_COMMAND_INFO_HASH}; + + my %commands; + my $command_libs = find_libraries('App::Yath::Command::*'); + for my $lib (sort keys %$command_libs) { + my $ok = eval { require $command_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load command '$command_libs->{$lib}': $@"; + next; + } + + next if $lib->internal_only; + my $name = $lib->name; + my $group = $lib->group; + $commands{$group}->{$name} = $lib->summary; + } + + return $self->{+_COMMAND_INFO_HASH} = \%commands; +} + +sub command_list { + my $self = shift; + + my $command_hash = $self->command_info_hash(); + my @commands = map keys %$_, values %$command_hash; + return @commands; +} + +sub run { + my $self = shift; + my $args = $self->{+ARGS}; + + return $self->command_help($args->[0]) if @$args; + + my $script = $self->settings->harness->script // $0; + my $maxlen = List::Util::max(map length, $self->command_list); + + print "\nUsage: $script COMMAND [options]\n\nAvailable Commands:\n"; + + my $command_info_hash = $self->command_info_hash; + for my $group (sort keys %$command_info_hash) { + my $set = $command_info_hash->{$group}; + + printf(" %${maxlen}s: %s\n", $_, $set->{$_}) for sort keys %$set; + print "\n"; + } + + return 0; +} + +sub command_help { + my $self = shift; + my ($command) = @_; + + require App::Yath; + my $cmd_class = App::Yath->load_command($command); + print $cmd_class->cli_help(settings => $self->{+SETTINGS}); + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/init.pm b/bad/App/Yath/Command/init.pm similarity index 100% rename from lib/App/Yath/Command/init.pm rename to bad/App/Yath/Command/init.pm diff --git a/lib/App/Yath/Command/kill.pm b/bad/App/Yath/Command/kill.pm similarity index 100% rename from lib/App/Yath/Command/kill.pm rename to bad/App/Yath/Command/kill.pm diff --git a/lib/App/Yath/Command/projects.pm b/bad/App/Yath/Command/projects.pm similarity index 100% rename from lib/App/Yath/Command/projects.pm rename to bad/App/Yath/Command/projects.pm diff --git a/lib/App/Yath/Command/ps.pm b/bad/App/Yath/Command/ps.pm similarity index 97% rename from lib/App/Yath/Command/ps.pm rename to bad/App/Yath/Command/ps.pm index 0a911f195..b29c63691 100644 --- a/lib/App/Yath/Command/ps.pm +++ b/bad/App/Yath/Command/ps.pm @@ -11,7 +11,6 @@ use App::Yath::Util qw/find_pfile/; use Test2::Harness::Runner::State; use Test2::Harness::Util::File::JSON(); -use Test2::Harness::Util::Queue(); use parent 'App::Yath::Command::status'; use Test2::Harness::Util::HashBase qw/queue/; diff --git a/lib/App/Yath/Command/reload.pm b/bad/App/Yath/Command/reload.pm similarity index 100% rename from lib/App/Yath/Command/reload.pm rename to bad/App/Yath/Command/reload.pm diff --git a/lib/App/Yath/Command/replay.pm b/bad/App/Yath/Command/replay.pm similarity index 100% rename from lib/App/Yath/Command/replay.pm rename to bad/App/Yath/Command/replay.pm diff --git a/bad/App/Yath/Command/resources.pm b/bad/App/Yath/Command/resources.pm new file mode 100644 index 000000000..f4e47e7c8 --- /dev/null +++ b/bad/App/Yath/Command/resources.pm @@ -0,0 +1,159 @@ +package App::Yath::Command::resources; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); +use Time::HiRes qw/sleep/; + +use App::Yath::Util qw/find_pfile/; + +use App::Yath::Options; +use Test2::Harness::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/+state/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Runner', +); + +sub group { 'state' } + +sub summary { "View the state info for a test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +A look at the state and resources used by a runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub newest { + my ($a, $b) = @_; + return $a unless $b; + return $b unless $a; + + my @as = stat($a); + my @bs = stat($b); + return $a if $as[9] > $bs[9]; + return $b; +} + +sub state { + my $self = shift; + + return $self->{+STATE} if $self->{+STATE}; + + my $info_file; + opendir(my $dh, "./") or die "Could not open current dir: $!"; + for my $file (readdir($dh)) { + next unless $file =~ m{^\.test_info\.\S+\.json$}; + $info_file = newest($info_file, "./$file"); + } + + my $pfile = find_pfile($self->settings, no_fatal => 1); + + if (my $use = newest($info_file, $pfile)) { + if ($info_file) { + my $data = Test2::Harness::Util::File::JSON->new(name => $info_file)->read; + return $self->{+STATE} = Test2::Harness::Runner::State->new(%$data, observe => 1); + } + + if (my $pfile = find_pfile($self->settings, no_fatal => 1)) { + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + my $workdir = $data->{dir}; + my $all_state = Test2::Harness::State->new(workdir => $workdir); + + return $self->{+STATE} = Test2::Harness::Runner::State->new( + all_state => $all_state, + observe => 1, + job_count => $all_state->job_count // 1, + workdir => $data->{dir}, + ); + } + } + + return; +} + +sub shared { + my $self = shift; + + my $shared; + eval { + require Test2::Harness::Runner::Resource::SharedJobSlots; + $shared = Test2::Harness::Runner::Resource::SharedJobSlots->new( + settings => $self->settings, + ); + 1; + }; + + return $shared; +} + +sub run { + my $self = shift; + + my $res; + + if(my $state = $self->state) { + my @list; + $res = sub { + unless (@list) { + $state->poll; + @list = (@{$state->resources}, undef); + } + + return shift @list; + }; + } + elsif (my $shared = $self->shared) { + my $alt = 0; + $res = sub { + if ($alt) { + $alt = 0; + return undef; + } + + $alt = 1; + return $shared; + }; + } + + die "No persistent runner, no running test, and no shared resources found\n" + unless $res; + + while (1) { + my @out = ( + "\r\e[2J\r\e[1;1H", + "\n==== Resource state ====\n", + ); + while (my $resource = $res->()) { + my @lines = $resource->status_lines; + next unless @lines; + push @out => ( + "\nResource: " . ref($resource) . "\n", + join "\n" => @lines, + ); + } + push @out => "\n\n"; + print @out; + sleep 0.1; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/bad/App/Yath/Command/run.pm b/bad/App/Yath/Command/run.pm new file mode 100644 index 000000000..9b549899f --- /dev/null +++ b/bad/App/Yath/Command/run.pm @@ -0,0 +1,232 @@ +package App::Yath::Command::run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; +use Test2::Harness::Util qw/mod2file open_file/; +use Test2::Util::Table qw/table/; + +use File::Spec; + +use Carp qw/croak/; + +use parent 'App::Yath::Command::test'; +use Test2::Harness::Util::HashBase qw/+pfile_data +pfile/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Finder', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Run', +); + +option_group {prefix => 'run'} => sub { + option check_reload_state => ( + type => 'b', + description => 'Abort the run if there are unfixes reload errors and show a confirmation dialogue for unfixed reload warnings.', + default => 1, + ); +}; + + +sub group { 'persist' } + +sub summary { "Run tests using the persistent test runner" } +sub cli_args { '[--] [test files/dirs] [::] [arguments to test scripts] [test_file.t] [test_file2.t="--arg1 --arg2 --param=\'foo bar\'"] [:: --argv-for-all-tests]' } + +sub description { + return <<" EOT"; +This command will run tests through an already started persistent instance. See +the start command for details on how to launch a persistant instance. + EOT +} + +sub write_settings_to {} +sub setup_plugins {} +sub setup_resources {} +sub teardown_plugins {} +sub finalize_plugins {} +sub pfile_params { () } + + +sub monitor_preloads { 1 } +sub job_count { 1 } + +sub collector_options { (persistent_runner => 1) } + +sub run { + my $self = shift; + + my $settings = $self->settings; + + if ($settings->run->check_reload_state) { + return 255 unless $self->check_reload_state; + } + + return $self->SUPER::run(@_); +} + +sub write_test_info { + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; +} + +sub check_reload_state { + my $self = shift; + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + my $reload_status = $state->reload_state // {}; + + my (@out, $errors, $warnings, %seen); + for my $stage (sort keys %$reload_status) { + for my $file (keys %{$reload_status->{$stage}}) { + next if $seen{$file}++; + my $data = $reload_status->{$stage}->{$file} or next; + + push @out => "\n==== SOURCE FILE: $file ====\n"; + if ($data->{error}) { + $errors++; + push @out => $data->{error}; + } + + for (@{$data->{warnings} // []}) { + push @out => $_; + $warnings++; + } + } + } + $errors //= 0; + $warnings //= 0; + + return 1 unless @out || $errors || $warnings; + + print <<" EOT", @out; +******************************************************************************* +* Some source files were reloaded with errors or warnings +* Errors: $errors +* Warnings: $warnings +******************************************************************************* + + EOT + + if ($errors) { + print <<" EOT"; + +******************************************************************************* +Aborting due to reload errors. Please fix the errors so that the modules reload +cleanly, then try the run again. In most cases you will not need to reload the +runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + + EOT + + return 0; + } + elsif ($warnings) { + print <<" EOT"; + +******************************************************************************* +Warnings were encountered when reloading source files, please see the output +above. If these warnings are a problem you should abort this run (control+c) +and correct them before trying again. In most cases you will not need to reload +the runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + +If these warnings are not indicitive of a problem you may continue by pressing +enter/return. + + EOT + + if (-t STDIN) { + my $ignore = ; + return 1; + } + else { + print STDERR "No TTY detected, aborting run due to warnings...\n"; + return 0; + } + } + + return 0; +} + +sub init { + my $self = shift; + + my $settings = $self->settings; + my $pdata = $self->pfile_data; + + my $state = Test2::Harness::State->new(workdir => $pdata->{dir}); + $self->{+STATE} = $state; + my $runner_settings = $state->data->settings; + + for my $prefix (sort keys %{$runner_settings}) { + next if $settings->check_prefix($prefix); + + my $new = $settings->define_prefix($prefix); + ${$new->vivify_field('from_runner')} = 1; + for my $key (sort keys %{$runner_settings->{$prefix}}) { + ${$new->vivify_field($key)} = $runner_settings->{$prefix}->{$key}; + } + } + + return $self->SUPER::init(@_); +} + +sub pfile { + my $self = shift; + $self->{+PFILE} //= find_pfile($self->settings, $self->pfile_params) or die "No persistent harness was found for the current path.\n"; +} + +sub pfile_data { + my $self = shift; + return $self->{+PFILE_DATA} if $self->{+PFILE_DATA}; + + my $pfile = $self->pfile; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + $data->{pfile_path} //= $pfile; + + print "\nFound: $data->{pfile_path}\n"; + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + + return $self->{+PFILE_DATA} = $data; +} + +sub workdir { + my $self = shift; + return $self->pfile_data->{dir}; +} + +sub start_runner { + my $self = shift; + + my $data = $self->pfile_data; + + $self->{+RUNNER_PID} = $data->{pid}; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/bad/App/Yath/Command/runner.pm b/bad/App/Yath/Command/runner.pm new file mode 100644 index 000000000..4e7ed42f2 --- /dev/null +++ b/bad/App/Yath/Command/runner.pm @@ -0,0 +1,519 @@ +package App::Yath::Command::runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Config qw/%Config/; +use File::Spec; + +# For some reason Filter::Util::Class breaks the STDIN filehandle. This works +# around that. +my $FIX_STDIN; +BEGIN { + require goto::file; + no strict 'refs'; + no warnings 'redefine'; + + my $int_done; + my $orig = goto::file->can('filter'); + *goto::file::filter = sub { + local $.; + my $out = $orig->(@_); + seek(STDIN, 0, 0) if $FIX_STDIN; + + unless ($int_done++) { + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + my $ok; + for (1 .. 10) { + $ok = open(STDIN, '<', $fifo); + last if $ok; + die "Could not open fifo ($fifo): $!"; + sleep 1; + } + + die "Could not open fifo ($fifo): $!" unless $ok; + + print STDERR <<' EOT'; + +******************************************************************************* +* YATH IS RUNNING IN INTERACTIVE MODE * +* * +* STDIN is comming from a fifo pipe, not a TTY! * +* * +* The $ENV{YATH_INTERACTIVE} var is set to the FIFO being used. * +* * +* VERBOSE mode has been turned on for you * +* * +* Only 1 test will run at a time * +* * +* The main yath process no longer has STDIN, so yath plugins that wait for * +* input WILL BREAK. * +* * +* Prompts that do not end with a newline may have a 1 second delay before * +* they are displayed, they will be prefixed with [INTERACTIVE] * +* * +* Any stdin/stdout that is printed in 2 parts without a newline and more than * +* a 1 second delay will be printed with the [INTERACTIVE] prefix, if they are * +* not actually a prompt you can safely ignore them. * +* * +* It is possible that a prompt was displayed before this message, please * +* check above if your prompt appears missing. This is an IO fluke, not a bug. * +* * +******************************************************************************* + + EOT + } + } + + return $out; + }; +} + +use Test2::Harness::IPC(); +use Test2::Harness::State; + +use Carp qw/confess/; +use Scalar::Util qw/openhandle/; +use List::Util qw/first/; +use File::Path qw/remove_tree/; + +use Scope::Guard; + +use Test2::Util qw/clone_io/; + +use Long::Jump qw/setjump longjump/; + +use Test2::Harness::Util qw/mod2file write_file_atomic open_file clean_path process_includes/; + +use Test2::Harness::Util::IPC qw/swap_io/; + +use Test2::Harness::Runner::Preloader(); + +my @SIGNALS = grep { $_ ne 'ZERO' } split /\s+/, $Config{sig_name}; + +# If FindBin is installed, go ahead and load it. We do not care much about +# success vs failure here. +BEGIN { + local $@; + eval { require FindBin; FindBin->import }; +} + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'runner' } + +sub init { confess(ref($_[0]) . " is not intended to be instantiated") } +sub run { confess(ref($_[0]) . " does not implement run()") } + +our $RUNNER_PID; +sub generate_run_sub { + my $class = shift; + my ($symbol, $argv, $spawn_settings) = @_; + my ($dir, %args) = @$argv; + + $RUNNER_PID = $$; + my $runner_pid = $$; + my $state = Test2::Harness::State->new(workdir => $dir); + my $settings = $state->settings; + + my $name = $ENV{NESTED_YATH} ? 'yath-nested-runner' : 'yath-runner'; + $name = $settings->debug->procname_prefix . "-${name}" if $settings->debug->procname_prefix; + $0 = $name; + + my $cleanup = $class->cleanup($settings, \%args, $dir); + + my $jump = setjump "Test-Runner" => sub { + local $.; + + my %orig_sig = %SIG; + my $guard = Scope::Guard->new(sub { + my %seen; + for my $sig (@SIGNALS) { + next if $seen{$sig}++; + if (exists $orig_sig{$sig}) { + $SIG{$sig} = $orig_sig{$sig}; + } + else { + delete $SIG{$sig}; + } + } + }); + + my $runner = $settings->build( + runner => 'Test2::Harness::Runner', + + %args, + + dir => $dir, + settings => $settings, + state => $state, + + fork_job_callback => sub { $class->launch_via_fork(@_) }, + fork_spawn_callback => sub { $class->launch_spawn(@_) }, + respawn_runner_callback => sub { return unless $$ == $runner_pid; longjump "Test-Runner" => 'respawn' }, + ); + + my $exit = $runner->process(); + + if ($$ == $runner_pid) { + $_->cleanup() for @{$state->resources}; + } + +# my $complete = File::Spec->catfile($dir, 'complete'); +# write_file_atomic($complete, '1'); + + exit($exit // 1); + }; + + die "Test runner completed, but failed to exit" unless $jump; + + my ($action, $job, $stage) = @$jump; + + if($action eq 'respawn') { + print "$$ Respawning the runner...\n"; + $cleanup->dismiss(1); + exec($^X, $settings->harness->script, @{$spawn_settings->harness->orig_argv}); + warn "exec failed!"; + exit 1; + } + + die "Invalid action: $action" if $action ne 'run_test'; + + if (my $chdir = $job->ch_dir) { + chdir($chdir) or die "Could not chdir: $!"; + } + goto::file->import($job->run_file); + $class->cleanup_process($job, $stage); + DB::enable_profile() if $settings->runner->nytprof; +} + +sub cleanup { + my $class = shift; + my ($settings, $args, $dir) = @_; + + my $pfile = $args->{persist} or return; + + my $pid = $$; + return Scope::Guard->new(sub { + return unless $pid == $$; + + unlink($pfile); + + remove_tree($dir, {safe => 1, keep_root => 0}) unless $settings->debug->keep_dirs; + }); +} + +sub get_stage { + my $class = shift; + my ($runner) = @_; + + return unless $runner->can('stage'); + + my $stage_name = $runner->stage or return; + my $preloader = $runner->preloader or return; + my $p = $preloader->staged or return; + + return $p->stage_lookup->{$stage_name}; +} + +sub launch_spawn { + my $class = shift; + my ($runner, $spawn) = @_; + + my $pid = fork() // die $!; + if ($pid) { + waitpid($pid, 0); + return; + } + + require POSIX; + POSIX::setsid or die "setsid: $!"; + + $pid = fork // die $!; + exit 0 if $pid; + + eval { + my ($wh); + pipe(STDIN, $wh) or die "Could not create pipe: $!"; + $pid = $class->launch_via_fork($runner, $spawn); + + if ($pid) { + open(my $fh, '>>', $spawn->{task}->{ipcfile}) or die "Could not open pidfile: $!"; + print $fh "$$\n$pid\n" . fileno($wh) . "\n"; + $fh->flush(); + waitpid($pid, 0); + print $fh "$?\n"; + close($fh); + } + + exit(0); + }; + warn "Unknown problem daemonizing: $@"; + exit(1); +} + +sub launch_via_fork { + my $class = shift; + my ($runner, $job) = @_; + + my $stage = $class->get_stage($runner); + + $stage->do_pre_fork($job) if $stage; + + my $pid = fork(); + die "Failed to fork: $!" unless defined $pid; + + # In parent + return $pid if $pid; + + # In Child + my $ok = eval { + $0 = 'yath-pending-test'; + setpgrp(0, 0) if Test2::Harness::IPC::USE_P_GROUPS(); + $runner->stop(); + + $stage->do_post_fork($job) if $stage; + + longjump "Test-Runner" => ('run_test', $job, $stage); + + 1; + }; + my $err = $@; + eval { warn $err } unless $ok; + exit(1); +} + +sub cleanup_process { + my $class = shift; + my ($job, $stage) = @_; + + $class->update_io($job); # Get the correct filehandles in place early + $class->set_env($job); # Set up the necessary env vars + $class->build_init_state($job); # Lots of 'misc' stuff. + $class->do_loads($job); # Modules that we wanted loaded/imported post fork + $class->test2_state($job); # Normalize the Test2 state + + $stage->do_pre_launch($job) if $stage; + + $class->final_state($job); # Important final cleanup +} + +sub test2_state { + my $class = shift; + my ($job) = @_; + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stop_preload(); + Test2::API::test2_post_preload_reset(); + } + + if ($job->use_stream) { + $ENV{T2_FORMATTER} = 'Stream'; + require Test2::Formatter::Stream; + Test2::Formatter::Stream->import(dir => $job->event_dir, job_id => $job->job_id); + } + + if ($job->event_uuids) { + require Test2::Plugin::UUID; + Test2::Plugin::UUID->import(); + } + + if ($job->mem_usage) { + require Test2::Plugin::MemUsage; + Test2::Plugin::MemUsage->import(); + } + + if ($job->io_events) { + require Test2::Plugin::IOEvents; + Test2::Plugin::IOEvents->import(); + } + + return; +} + +sub final_state { + my $class = shift; + my ($job) = @_; + + @ARGV = $job->args; + + # toggle -w switch late + $^W = 1 if $job->use_w_switch; + + # reset the state of empty pattern matches, so that they have the same + # behavior as running in a clean process. + # see "The empty pattern //" in perlop. + # note that this has to be dynamically scoped and can't go to other subs + "" =~ /^/; + + return; +} + +sub do_loads { + my $class = shift; + my ($job) = @_; + + local $@; + my $importer = eval <<' EOT' or die $@; +package main; +#line 0 "-" +sub { $_[0]->import(@{$_[1]}) } + EOT + + for my $set ($job->load_import) { + my ($mod, $args) = @$set; + my $file = mod2file($mod); + local $0 = '-'; + require $file; + $importer->($mod, $args); + } + + for my $mod ($job->load) { + my $file = mod2file($mod); + local $0 = '-'; + require $file; + } + + return; +} + +sub build_init_state { + my $class = shift; + my ($job) = @_; + + $0 = $job->rel_file; + $class->_reset_DATA(); + @ARGV = (); + + srand(); # avoid child processes sharing the same seed value as the parent + + @INC = process_includes( + list => [$job->includes], + include_dot => $job->unsafe_inc, + include_current => 1, + clean => 1, + ); + + # if FindBin is preloaded, reset it with the new $0 + FindBin::init() if defined &FindBin::init; + + # restore defaults + Getopt::Long::ConfigDefaults() if defined &Getopt::Long::ConfigDefaults; + + return; +} + +sub set_env { + my $class = shift; + my ($job) = @_; + + my $env = $job->env_vars; + { + no warnings 'uninitialized'; + $ENV{$_} = $env->{$_} for keys %$env; + } + + $ENV{T2_HARNESS_FORKED} = 1; + $ENV{T2_HARNESS_PRELOAD} = 1; + + return; +} + +sub update_io { + my $class = shift; + my ($job) = @_; + + my $out_fh = open_file($job->out_file, '>'); + my $err_fh = open_file($job->err_file, '>'); + + my $in_file = $job->in_file; + my $in_fh = open_file($in_file, '<') if $in_file; + + $out_fh->autoflush(1); + $err_fh->autoflush(1); + + # Keep a copy of the old STDERR for a while so we can still report errors + my $stderr = clone_io(\*STDERR); + + my $die = sub { + my @caller = caller; + my @caller2 = caller(1); + my $msg = "$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2]).\n"; + print $stderr $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $in_fh, $die, '<&') if $in_file; + swap_io(\*STDOUT, $out_fh, $die, '>&'); + swap_io(\*STDERR, $err_fh, $die, '>&'); + + $FIX_STDIN = 1 if $in_file; + + return; +} + +# Heavily modified from forkprove +sub _reset_DATA { + my $class = shift; + + for my $set (@{$class->preload_list}) { + my ($mod, $file, $pos) = @$set; + + my $fh = do { + no strict 'refs'; + *{$mod . '::DATA'}; + }; + + # note that we need to ensure that each forked copy is using a + # different file handle, or else concurrent processes will interfere + # with each other + + close $fh if openhandle($fh); + + if (open $fh, '<', $file) { + seek($fh, $pos, 0); + } + else { + warn "Couldn't reopen DATA for $mod ($file): $!"; + } + } +} + +# Heavily modified from forkprove +sub preload_list { + my $class = shift; + + my $list = []; + + for my $loaded (keys %INC) { + next unless $loaded =~ /\.pm$/; + + my $mod = $loaded; + $mod =~ s{/}{::}g; + $mod =~ s{\.pm$}{}; + + my $fh = do { + no strict 'refs'; + no warnings 'once'; + *{$mod . '::DATA'}; + }; + + next unless openhandle($fh); + push @$list => [$mod, $INC{$loaded}, tell($fh)]; + } + + return $list; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/spawn.pm b/bad/App/Yath/Command/spawn.pm similarity index 100% rename from lib/App/Yath/Command/spawn.pm rename to bad/App/Yath/Command/spawn.pm diff --git a/lib/App/Yath/Command/speedtag.pm b/bad/App/Yath/Command/speedtag.pm similarity index 100% rename from lib/App/Yath/Command/speedtag.pm rename to bad/App/Yath/Command/speedtag.pm diff --git a/bad/App/Yath/Command/start.pm b/bad/App/Yath/Command/start.pm new file mode 100644 index 000000000..b74c4bb95 --- /dev/null +++ b/bad/App/Yath/Command/start.pm @@ -0,0 +1,207 @@ +package App::Yath::Command::start; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util qw/mod2file open_file parse_exit clean_path/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use POSIX; +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Time::HiRes qw/sleep/; + +use Carp qw/croak/; +use File::Path qw/remove_tree/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Workspace', + 'App::Yath::Options::Persist', + 'App::Yath::Options::Collector', +); + +option_group {prefix => 'runner', category => "Persistent Runner Options"} => sub { + option reload => ( + short => 'r', + type => 'b', + description => "Attempt to reload modified modules in-place, restarting entire stages only when necessary.", + default => 0, + ); + + option restrict_reload => ( + type => 'D', + long_examples => ['', '=path'], + short_examples => ['', '=path'], + description => "Only reload modules under the specified path, if no path is specified look at anything under the .yath.rc path, or the current working directory.", + + normalize => sub { $_[0] eq '1' ? $_[0] : clean_path($_[0]) }, + action => \&restrict_action, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); +}; + +sub restrict_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + if ($norm eq '1') { + my $hset = $settings->harness; + my $path = $hset->config_file || $hset->cwd; + $path //= do { require Cwd; Cwd::getcwd() }; + $path =~ s{\.yath\.rc$}{}g; + push @{$$slot} => $path; + } + else { + push @{$$slot} => $norm; + } +} + +sub MAX_ATTACH() { 1_048_576 } + +sub group { 'persist' } + +sub always_keep_dir { 1 } + +sub summary { "Start the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command is used to start a persistant instance of yath. A persistant +instance is useful because it allows you to preload modules in advance, +reducing start time for any tests you decide to run as you work. + +A running instance will watch for changes to any preloaded files, and restart +itself if anything changes. Changed files are blacklisted for subsequent +reloads so that reloading is not a frequent occurence when editing the same +file over and over again. + EOT +} + +sub run { + my $self = shift; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my $pfile = find_pfile($settings, vivify => 1, no_checks => 1); + + if (-f $pfile) { + remove_tree($dir, {safe => 1, keep_root => 0}); + die "Persistent harness appears to be running, found $pfile\n"; + } + + my $all_state = Test2::Harness::State->new( + workdir => $dir, + settings => $settings, + ); + $all_state->transaction(w => sub { 1 }); + + $self->setup_plugins(); + $self->setup_resources(); + + my $stderr = File::Spec->catfile($dir, 'error.log'); + my $stdout = File::Spec->catfile($dir, 'output.log'); + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $pid = run_cmd( + stderr => $stderr, + stdout => $stdout, + + no_set_pgrp => !$settings->runner->daemon, + + command => [ + $^X, @prof, $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + monitor_preloads => 1, + persist => $pfile, + jobs_todo => 0, + ], + ); + + unless ($settings->runner->quiet) { + print "\nPersistent runner started!\n"; + + print "Runner PID: $pid\n"; + print "Runner dir: $dir\n"; + print "\nUse `yath watch` to monitor the persistent runner\n\n" if $settings->runner->daemon; + } + + Test2::Harness::Util::File::JSON->new(name => $pfile)->write({ + pid => $pid, + dir => $dir, + version => $VERSION, + user => $ENV{USER}, + hostname => hostname(), + }); + + return 0 if $settings->runner->daemon; + + $SIG{TERM} = sub { kill(TERM => $pid) }; + $SIG{INT} = sub { kill(INT => $pid) }; + + my $err_fh = open_file($stderr, '<'); + my $out_fh = open_file($stdout, '<'); + + while (1) { + my $out = waitpid($pid, WNOHANG); + my $wstat = $?; + + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + sleep(0.02) unless $out || $count; + + next if $out == 0; + return 255 if $out < 0; + + my $exit = parse_exit($?); + return $exit->{err} || $exit->{sig} || 0; + } +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/status.pm b/bad/App/Yath/Command/status.pm similarity index 99% rename from lib/App/Yath/Command/status.pm rename to bad/App/Yath/Command/status.pm index 6432fb5e2..2b1f0bd1b 100644 --- a/lib/App/Yath/Command/status.pm +++ b/bad/App/Yath/Command/status.pm @@ -9,7 +9,6 @@ use File::Spec(); use Test2::Harness::Runner::State; use Test2::Harness::Util::File::JSON(); -use Test2::Harness::Util::Queue(); use parent 'App::Yath::Command::run'; use Test2::Harness::Util::HashBase; diff --git a/lib/App/Yath/Command/stop.pm b/bad/App/Yath/Command/stop.pm similarity index 96% rename from lib/App/Yath/Command/stop.pm rename to bad/App/Yath/Command/stop.pm index 514181aa6..4cb488e5f 100644 --- a/lib/App/Yath/Command/stop.pm +++ b/bad/App/Yath/Command/stop.pm @@ -9,7 +9,6 @@ use Time::HiRes qw/sleep/; use File::Spec(); use Test2::Harness::Util::File::JSON(); -use Test2::Harness::Util::Queue(); use Test2::Harness::Util qw/open_file/; use App::Yath::Util qw/find_pfile/; diff --git a/bad/App/Yath/Command/test.pm b/bad/App/Yath/Command/test.pm new file mode 100644 index 000000000..9ffe6d126 --- /dev/null +++ b/bad/App/Yath/Command/test.pm @@ -0,0 +1,865 @@ +package App::Yath::Command::test; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Event; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Util::JSON qw/encode_json decode_json JSON/; +use Test2::Harness::Util qw/mod2file open_file chmod_tmp/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + +use File::Spec; +use Fcntl(); + +use Time::HiRes qw/sleep time/; +use List::Util qw/sum max min/; +use Carp qw/croak/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/ + '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + } + + my $plugins = $settings->harness->plugins; + if (@$plugins) { + push @out => $_->spawn_args($settings) for grep { $_->can('spawn_args') } @$plugins; + } + + return @out; +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; + + $self->{+CLEANUP_SUBS} = []; +} + +sub _resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh) = @_; + + # 1mb if we can + my $size = 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub auditor_reader { + my $self = shift; + return $self->{+AUDITOR_READER} if $self->{+AUDITOR_READER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+AUDITOR_READER}; +} + +sub collector_writer { + my $self = shift; + return $self->{+COLLECTOR_WRITER} if $self->{+COLLECTOR_WRITER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+COLLECTOR_WRITER}; +} + +sub renderer_reader { + my $self = shift; + return $self->{+RENDERER_READER} if $self->{+RENDERER_READER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+RENDERER_READER}; +} + +sub auditor_writer { + my $self = shift; + return $self->{+AUDITOR_WRITER} if $self->{+AUDITOR_WRITER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+AUDITOR_WRITER}; +} + +sub workdir { + my $self = shift; + $self->settings->workspace->workdir; +} + +sub ipc { + my $self = shift; + return $self->{+IPC} //= Test2::Harness::IPC->new( + handlers => { + INT => sub { $self->handle_sig(@_) }, + TERM => sub { $self->handle_sig(@_) }, + } + ); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + eval { $_->signal($sig) } for grep { $_->can('signal') } @{$self->renderers}; + + print STDERR "\nCaught SIG$sig, forwarding signal to child processes...\n"; + $self->ipc->killall($sig); + + if ($self->{+SIGNAL}) { + print STDERR "\nSecond signal ($self->{+SIGNAL} followed by $sig), exiting now without waiting\n"; + exit 1; + } + + $self->{+SIGNAL} = $sig; +} + +sub monitor_preloads { 0 } + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $plugins = $self->settings->harness->plugins; + + if ($self->start()) { + $self->render(); + $self->stop(); + + my $final_data = $self->{+FINAL_DATA} or die "Final data never received from auditor!\n"; + my $pass = $self->{+TESTS_SEEN} && $final_data->{pass}; + $self->render_final_data($final_data); + $self->produce_summary($pass); + + if (@$plugins) { + my %args = ( + settings => $settings, + final_data => $final_data, + pass => $pass ? 1 : 0, + tests_seen => $self->{+TESTS_SEEN} // 0, + asserts_seen => $self->{+ASSERTS_SEEN} // 0, + ); + $_->finish(%args) for @$plugins; + } + + return $pass ? 0 : 1; + } + + $self->stop(); + + return 1; +} + +sub DESTROY { + my $self = shift; + + local ($?, $!, $@, $_); + + my $cleanup = delete $self->{+CLEANUP_SUBS} or return; + for my $sub (@$cleanup) { + eval { $sub->(); 1 } or warn $@; + } +} + +sub write_test_info { + my $self = shift; + + return if $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO}; + + my $info_file = "./.test_info.$$.json"; + + my $workdir = $self->workdir; + Test2::Harness::Util::File::JSON->new(name => $info_file)->write({ + workdir => $self->workdir, + job_count => $self->job_count, + }); + + push @{$self->{+CLEANUP_SUBS}} => sub { + return unless -e $info_file; + return unless Test2::Harness::Util::File::JSON->new(name => $info_file)->read->{workdir} eq $workdir; + unlink($info_file) or die "Could not unlink info file: $!"; + }; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} = 1; +} + +sub start { + my $self = shift; + + $self->state->transaction(w => sub { 1 }); + + $self->ipc->start(); + $self->parse_args; + + $self->write_test_info(); + my $pop = $self->populate_queue(); + return unless $pop; + + $self->setup_plugins(); + $self->setup_resources(); + + $self->start_runner(jobs_todo => $pop); + $self->start_collector(); + $self->start_auditor(); + + return 1; +} + +sub render { + my $self = shift; + + my $ipc = $self->ipc; + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + my $plugins = $self->settings->harness->plugins; + + my $handle_plugins = [grep { $_->can('handle_event') } @$plugins]; + my $annotate_plugins = [grep { $_->can('annotate_event') } @$plugins]; + + # render results from log + my $reader = $self->renderer_reader(); + $reader->blocking(0); + my $buffer; + while (1) { + return if $self->{+SIGNAL}; + $_->step for @{$renderers}; + + my $line = <$reader>; + unless(defined $line) { + $ipc->wait() if $ipc; + sleep 0.02; + next; + } + + if ($buffer) { + $line = $buffer . $line; + $buffer = undef; + } + + unless (substr($line, -1, 1) eq "\n") { + $buffer //= ""; + $buffer .= $line; + next; + } + + my $e = decode_json($line); + + if (defined $e) { + bless($e, 'Test2::Harness::Event'); + my $fd = $e->{facet_data} //= {}; + + my $changed = 0; + for my $p (@$annotate_plugins) { + my %inject = $p->annotate_event($e, $settings); + next unless keys %inject; + $changed++; + + # Can add new facets, but not modify existing ones. + # Someone could force the issue by modifying the event directly + # inside 'annotate_event', this is not supported, but also not + # forbidden, user beware. + for my $f (keys %inject) { + if (exists $fd->{$f}) { + if ('ARRAY' eq ref($fd->{$f})) { + push @{$fd->{$f}} => @{$inject{$f}}; + } + else { + warn "Plugin '$p' tried to add facet '$f' via 'annotate_event()', but it is already present and not a list, ignoring plugin annotation.\n"; + } + } + else { + $fd->{$f} = $inject{$f}; + } + } + + } + + if ($logger) { + if ($changed) { + my $newline = $e->as_json; + print $logger $newline, "\n"; + } + else { + print $logger $line; + } + } + } + else { + last; + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + $_->render_event($e) for @$renderers; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + $_->handle_event($e, $settings) for @$handle_plugins; + + $ipc->wait() if $ipc; + } +} + +sub stop { + my $self = shift; + + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + + $self->teardown_plugins($renderers, $logger); + if ($logger) { + print $logger "null\n"; + close($logger); + } + + $_->finish() for @$renderers; + + my $ipc = $self->ipc; + + if ($self->{+SIGNAL}) { + print STDERR "Waiting for child processes to exit...\n"; + $self->state->scheduler->halt_run($self->{+RUN_ID}); + } + + $ipc->wait(all => 1); + $ipc->stop; + + unless ($settings->display->quiet > 2) { + printf STDERR "\nNo tests were seen!\n" unless $self->{+TESTS_SEEN}; + + printf("\nKeeping work dir: %s\n", $self->workdir) + if $settings->debug->keep_dirs; + + if ($settings->logging->log) { + print "\n"; + print "Wrote log file: " . $settings->logging->log_file . "\n"; + print " (Symlinked to: " . $self->{+LAST_LOG} . ")\n"; + } + + $self->finalize_plugins(); + } +} + +sub build_run { + my $self = shift; + + return $self->{+RUN} if $self->{+RUN}; + + my $settings = $self->settings; + my $dir = $self->workdir; + + my $run = $settings->build(run => 'Test2::Harness::Run'); + + mkdir($run->run_dir($dir)) or die "Could not make run dir: $!"; + chmod_tmp($dir); + + return $self->{+RUN} = $run; +} + +sub state { + my $self = shift; + + $self->{+STATE} //= Test2::Harness::State->new( + workdir => $self->workdir, + job_count => $self->job_count, + settings => $self->settings, + ); +} + +sub job_count { + my $self = shift; + + return $self->settings->runner->job_count; +} + +sub finder_args {()} + +sub populate_queue { + my $self = shift; + + my $run = $self->build_run(); + $self->{+RUN_ID} = $run->run_id; + my $settings = $self->settings; + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + + my $plugins = $settings->harness->plugins; + + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my @add_to_queue; + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + push @add_to_queue => $task; + } + + $self->state->add_run( + $run->queue_item($plugins), + jobs => \@add_to_queue, + ); + + return $job_count; +} + +sub produce_summary { + my $self = shift; + my ($pass) = @_; + + my $settings = $self->settings; + + my $time_data = { + start => $settings->harness->start, + stop => time(), + }; + + $time_data->{wall} = $time_data->{stop} - $time_data->{start}; + + my @times = times(); + @{$time_data}{qw/user system cuser csystem/} = @times; + $time_data->{cpu} = sum @times; + + my $cpu_usage = int($time_data->{cpu} / $time_data->{wall} * 100); + + $self->write_summary($pass, $time_data, $cpu_usage); + $self->render_summary($pass, $time_data, $cpu_usage); +} + +sub write_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + my $file = $self->settings->debug->summary or return; + + my $final_data = $self->{+FINAL_DATA}; + + my $failures = @{$final_data->{failed} // []}; + + my %data = ( + %$final_data, + + pass => $pass ? JSON->true : JSON->false, + + total_failures => $failures // 0, + total_tests => $self->{+TESTS_SEEN} // 0, + total_asserts => $self->{+ASSERTS_SEEN} // 0, + + cpu_usage => $cpu_usage, + + times => $time_data, + ); + + require Test2::Harness::Util::File::JSON; + my $jfile = Test2::Harness::Util::File::JSON->new(name => $file); + $jfile->write(\%data); + + print "\nWrote summary file: $file\n\n"; + + return; +} + +sub render_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + return if $self->settings->display->quiet > 1; + + my $final_data = $self->{+FINAL_DATA}; + my $failures = @{$final_data->{failed} // []}; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $self->{+TESTS_SEEN}", + "Assertion Count: $self->{+ASSERTS_SEEN}", + $time_data ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->settings->display->color && USE_ANSI_COLOR) { + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + +sub render_final_data { + my $self = shift; + my ($final_data) = @_; + + return if $self->settings->display->quiet > 1; + + if (my $rows = $final_data->{retried}) { + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + header => ['Job ID', 'Times Run', 'Test File', "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{failed}) { + print "\nThe following jobs failed:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Test File', 'Subtests'], + rows => [map { my $r = [@{$_}]; $r->[2] = stringify_subtest_map($r->[2]) if $r->[2]; $r} @$rows], + ); + print "\n"; + } + + if (my $rows = $final_data->{halted}) { + print "\nThe following jobs requested all testing be halted:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File', "Reason"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{unseen}) { + print "\nThe following jobs never ran:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File'], + rows => $rows, + ); + print "\n"; + } +} + +sub stringify_subtest_map { + my ($map) = @_; + + my $out = ""; + my @todo = @$map; + my @state; + while (my $st = shift @todo) { + if (!ref($st)) { + pop @state if $st eq 'pop'; + next; + } + push @state => $st->[0]; + $out .= join(' -> ' => @state) . "\n"; + unshift @todo => (@{$st->[1]}, 'pop'); + } + + return $out; +} + +sub logger { + my $self = shift; + + return $self->{+LOGGER} if $self->{+LOGGER}; + + my $settings = $self->{+SETTINGS}; + + return unless $settings->logging->log; + + my $file = $settings->logging->log_file; + + if ($settings->logging->bzip2) { + no warnings 'once'; + require IO::Compress::Bzip2; + $self->{+LOGGER} = IO::Compress::Bzip2->new($file) or die "Could not open log file '$file': $IO::Compress::Bzip2::Bzip2Error"; + } + elsif ($settings->logging->gzip) { + no warnings 'once'; + require IO::Compress::Gzip; + $self->{+LOGGER} = IO::Compress::Gzip->new($file) or die "Could not open log file '$file': $IO::Compress::Gzip::GzipError"; + } + else { + $self->{+LOGGER} = open_file($file, '>'); + } + + for my $ext ('jsonl', 'jsonl.bz2', 'jsonl.gz') { + my $name = "./lastlog.$ext"; + next unless -f $name; + local ($!, $@) = (0, ''); + eval { unlink($name) } or warn "Could not unlink '$name': ($!) $@"; + } + + if ($file =~ m/\.(jsonl(?:\.(?:bz2|gz))?)$/) { + my $ext = $1; + my $name = "./lastlog.$ext"; + if (eval { symlink($file, $name); 1 }) { + $self->{+LAST_LOG} = $name; + } + else { + warn "Could not symlink the log file to '$name': $@"; + } + } + + return $self->{+LOGGER}; +} + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + my @renderers; + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub start_auditor { + my $self = shift; + + my $run = $self->build_run(); + my $settings = $self->settings; + + my $ipc = $self->ipc; + $ipc->spawn( + stdin => $self->auditor_reader(), + stdout => $self->auditor_writer(), + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + auditor => 'Test2::Harness::Auditor', + $run->run_id, + procname_prefix => $settings->debug->procname_prefix, + ], + ); + + close($self->auditor_writer()); +} + +sub collector_options { () } + +sub start_collector { + my $self = shift; + + my $dir = $self->workdir; + my $run = $self->build_run(); + my $settings = $self->settings; + my $runner_pid = $self->runner_pid; + + my ($rh, $wh); + pipe($rh, $wh) or die "Could not create pipe"; + + my %options = (show_runner_output => 1); + if ($settings->check_prefix('display')) { + $options{show_runner_output} = $settings->display->hide_runner_output ? 0 : 1; + $options{truncate_runner_output} = $settings->display->truncate_runner_output; + } + + %options = ( + %options, + $self->collector_options(), + ); + + my $ipc = $self->ipc; + $ipc->spawn( + stdout => $self->collector_writer, + stdin => $rh, + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + collector => 'Test2::Harness::Collector', + $dir, $run->run_id, $runner_pid, + %options, + ], + ); + + close($rh); + print $wh encode_json($run) . "\n"; + close($wh); + + close($self->collector_writer()); +} + +sub start_runner { + my $self = shift; + my %args = @_; + + $args{monitor_preloads} //= $self->monitor_preloads; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $ipc = $self->ipc; + my $proc = $ipc->spawn( + stderr => File::Spec->catfile($dir, 'error.log'), + stdout => File::Spec->catfile($dir, 'output.log'), + env_vars => { @prof ? (NYTPROF => 'start=no:addpid=1') : () }, + no_set_pgrp => 1, + command => [ + $^X, @prof, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + %args, + ], + ); + + $self->{+RUNNER_PID} = $proc->pid; + + return $proc; +} + +sub parse_args { + my $self = shift; + my $settings = $self->settings; + my $args = $self->args; + + my $dest = $settings->finder->search; + for my $arg (@$args) { + next if $arg eq '--'; + if ($arg eq '::') { + $dest = $settings->run->test_args; + next; + } + + push @$dest => $arg; + } + + return; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/times.pm b/bad/App/Yath/Command/times.pm similarity index 100% rename from lib/App/Yath/Command/times.pm rename to bad/App/Yath/Command/times.pm diff --git a/bad/App/Yath/Command/watch.pm b/bad/App/Yath/Command/watch.pm new file mode 100644 index 000000000..edd935c63 --- /dev/null +++ b/bad/App/Yath/Command/watch.pm @@ -0,0 +1,100 @@ +package App::Yath::Command::watch; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; + +use Test2::Harness::Util::File::JSON; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Monitor the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will tail the logs from a persistent instance of yath. STDOUT and +STDERR will be printed as seen, so may not be in proper order. + EOT +} + +sub run { + my $self = shift; + + my $args = $self->args; + shift @$args if @$args && $args->[0] eq '--'; + my $stop = 1 if @$args && $args->[0] eq 'STOP'; + + my $pfile = find_pfile($self->settings, no_fatal => 1) + or die "No persistent harness was found for the current path.\n"; + + print "\nFound: $pfile\n"; + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + print "\n"; + + my $err_f = File::Spec->catfile($data->{dir}, 'error.log'); + my $out_f = File::Spec->catfile($data->{dir}, 'output.log'); + + my $err_fh = open_file($err_f, '<'); + my $out_fh = open_file($out_f, '<'); + + my $auxdir = File::Spec->catdir($data->{dir}, 'aux_logs'); + my %aux; + + while (1) { + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + if (-d $auxdir) { + opendir(my $dh, $auxdir) or die "Could not open auxdir: $!"; + for my $file (readdir($dh)) { + next if $aux{$file}; + next unless $file =~ m/\.log$/; + my $full = File::Spec->catfile($auxdir, $file); + next unless -f $full; + $aux{$file} = open_file($full, '<'); + $count++; + } + } + + for my $file (sort keys %aux) { + my $fh = $aux{$file}; + my $ofh = $file =~ m/STDERR/ ? \*STDERR : \*STDOUT; + while (my $line = <$fh>) { + print $ofh $line; + } + } + + next if $count; + last if $stop; + last unless -f $pfile; + sleep 0.02; + } + + return 0; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/which.pm b/bad/App/Yath/Command/which.pm similarity index 100% rename from lib/App/Yath/Command/which.pm rename to bad/App/Yath/Command/which.pm diff --git a/lib/App/Yath/Converting.pm b/bad/App/Yath/Converting.pm similarity index 100% rename from lib/App/Yath/Converting.pm rename to bad/App/Yath/Converting.pm diff --git a/bad/App/Yath/Option.pm b/bad/App/Yath/Option.pm new file mode 100644 index 000000000..5cfac4cba --- /dev/null +++ b/bad/App/Yath/Option.pm @@ -0,0 +1,1157 @@ +package App::Yath::Option; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use Test2::Harness::Util::HashBase qw{ + 1, + c => 1, + s => 1, + m => 1, + d => 1, + D => 1, + h => 1, + H => 1, +); +sub valid_type { $TYPES{$_[-1]} } + +my %LONG_TO_SHORT_TYPES = ( + bool => 'b', + boolean => 'b', + + count => 'c', + counter => 'c', + counting => 'c', + + scalar => 's', + string => 's', + number => 's', + + multi => 'm', + multiple => 'm', + list => 'm', + array => 'm', + + default => 'd', + def => 'd', + + 'multi-def' => 'D', + 'multiple-default' => 'D', + 'list-default' => 'D', + 'array-default' => 'D', + + 'hash' => 'h', + 'hash-list' => 'H', +); +sub canon_type { $LONG_TO_SHORT_TYPES{$_[-1]} } + +my %REQUIRES_ARG = (s => 1, m => 1, h => 1, H => 1); +sub requires_arg { $REQUIRES_ARG{$_[0]->{+TYPE}} } + +my %ALLOWS_ARG = (d => 1, D => 1); +sub allows_arg { $ALLOWS_ARG{$_[0]->{+TYPE}} || $REQUIRES_ARG{$_[0]->{+TYPE} } } + +sub init { + my $self = shift; + + confess "You must specify 'title' or both 'field' and 'name'" + unless $self->{+TITLE} || ($self->{+FIELD} && $self->{+NAME}); + + confess "The 'prefix' attribute is required" + unless $self->{+PREFIX}; + + confess "The 'alt' attribute must be an array-ref" + if $self->{+ALT} && ref($self->{+ALT}) ne 'ARRAY'; + + if (my $title = $self->{+TITLE}) { + $self->{+FIELD} //= $title; + $self->{+NAME} //= ($self->{+FROM_PLUGIN} && $self->{+PREFIX}) ? "$self->{+PREFIX}-$title" : $title; + } + + $self->{+FIELD} =~ s/-/_/g; + $self->{+NAME} =~ s/_/-/g; + + if (my $class = $self->{+BUILDS}) { + confess "class '$class' does not have a '$self->{+FIELD}' method" + unless $class->can($self->{+FIELD}) || $self->{+IGNORE_FOR_BUILD}; + } + + $self->{+TYPE} //= 'b'; + $self->{+TYPE} = $self->canon_type($self->{+TYPE}) // $self->{+TYPE} if length($self->{+TYPE}) > 1; + confess "Invalid type '$self->{+TYPE}'" unless $self->valid_type($self->{+TYPE}); + + if ($self->{+TYPE} eq 'd' || $self->{+TYPE} eq 'D') { + $self->{+AUTOFILL} //= 1; + } + elsif(defined $self->{+AUTOFILL}) { + confess "'autofill' not supported for this type ('$self->{+TYPE}')"; + } + + if (my $def = $self->{+DEFAULT}) { + my $ref = ref($def); + confess "'default' must be a simple scalar, or a coderef, got a '$ref'" if $ref && $ref ne 'CODE'; + } + + for my $key (NORMALIZE(), ACTION()) { + my $val = $self->{$key} or next; + my $ref = ref($val) || 'not a ref'; + next if $ref eq 'CODE'; + confess "'$key' must be undef, or a coderef, got '$ref'"; + } + + $self->{+TRACE} //= [caller(1)]; + $self->{+CATEGORY} //= 'NO CATEGORY - FIX ME'; + $self->{+DESCRIPTION} //= 'NO DESCRIPTION - FIX ME'; + + for my $key (sort keys %$self) { + confess "'$key' is not a valid option attribute" + unless $self->can(uc($key)); + } + + return $self; +} + +sub applicable { + my $self = shift; + my ($options) = @_; + my $cb = $self->{+APPLICABLE} or return 1; + return $self->$cb($options); +} + +sub long_args { + my $self = shift; + + return ($self->{+NAME}, @{$self->{+ALT} || []}); +} + +sub option_slot { + my $self = shift; + my ($settings) = @_; + + confess "A settings instance is required" unless $settings; + return $settings->define_prefix($self->{+PREFIX})->vivify_field($self->{+FIELD}); +} + +sub get_default { + my $self = shift; + + for my $var (@{$self->{+ENV_VARS} // []}) { + my ($neg) = $var =~ s/^(!)//; + next unless exists $ENV{$var}; + return !$ENV{$var} if $neg; + return $ENV{$var}; + } + + if (defined $self->{+DEFAULT}) { + my $def = $self->{+DEFAULT}; + + return $self->$def() if ref($def); + + return $def; + } + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return undef; +} + +sub get_normalized { + my $self = shift; + my ($raw) = @_; + + return $self->{+NORMALIZE}->($raw) + if $self->{+NORMALIZE}; + + return $raw ? 1 : 0 + if $self->{+TYPE} eq 'b'; + + if (lc($self->{+TYPE}) eq 'h') { + my ($key, $val) = split /=/, $raw, 2; + + if ($self->{+TYPE} eq 'H') { + $val //= ''; + $val = [split /,/, $val]; + return [$key, $val]; + } + + return [$key, $val // 1]; + } + + return $raw; +} + +my %HANDLERS = ( + c => sub { ${$_[0]}++ }, + m => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + D => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + h => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $val = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + $hash->{$key} = $val; + }, + H => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $vals = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + push @{$hash->{$key} //= []} => @$vals; + }, +); + +sub handle { + my $self = shift; + my ($raw, $settings, $options, $list) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + my $norm = $self->get_normalized($raw); + + my $handler = $HANDLERS{$self->{+TYPE}} //= sub { ${$_[0]} = $_[1] }; + + return $self->{+ACTION}->($self->{+PREFIX}, $self->{+FIELD}, $raw, $norm, $slot, $settings, $handler, $options) + if $self->{+ACTION}; + + return $handler->($slot, $norm); +} + +sub handle_negation { + my $self = shift; + my ($settings, $options) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + + return $self->{+NEGATE}->($self->{+PREFIX}, $self->{+FIELD}, $slot, $settings, $options) + if $self->{+NEGATE}; + + return $$slot = 0 + if $self->{+TYPE} eq 'b' + || $self->{+TYPE} eq 'c'; + + return @{$$slot //= []} = () + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return %{$$slot //= {}} = () + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return $$slot = undef; +} + +sub trace_string { + my $self = shift; + my $trace = $self->{+TRACE} or return "[UNKNOWN]"; + return "$trace->[1] line $trace->[2]"; +} + +my %TYPE_LONG_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]'], + D => ['[=ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_SHORT_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]', '[ARG]'], + D => ['[=ARG]', '[ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_NOTES = ( + 'c' => "Can be specified multiple times", + 'm' => "Can be specified multiple times", + 'D' => "Can be specified multiple times", + 'h' => "Can be specified multiple times", + 'H' => "Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together.", +); + +sub cli_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + + push @forms => "--no-$self->{+NAME}"; + + my @out; + + require App::Yath::Util; + require Test2::Util::Term; + + my $width = Test2::Util::Term::term_size() - 20; + $width = 80 unless $width && $width >= 80; + + push @out => App::Yath::Util::fit_to_width($width, ", ", \@forms); + + my $desc = App::Yath::Util::fit_to_width($width, " ", $self->{+DESCRIPTION}); + $desc =~ s/^/ /gm; + push @out => $desc; + + push @out => "\n Can also be set with the following environment variables: " . join(", ", @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => "\n Note: " . $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join "\n" => @out; +} + +sub pod_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + push @forms => "--no-$self->{+NAME}"; + + my @out = map { "=item $_" } @forms; + + push @out => $self->{+DESCRIPTION}; + + push @out => "Can also be set with the following environment variables: " . join(", ", map { "C<$_>" } @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join("\n\n" => @out) . "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Option - Representation of a yath option. + +=head1 DESCRIPTION + +This class represents a single command line option for yath. + +=head1 SYNOPSIS + +You usually will not be creating option instances directly. Usually you will +use App::Yath::Options which provides sugar, and helps make sure options get to +the right place. + + use App::Yath::Options; + + # You can specify a single option: + option color => ( + prefix => 'display', + category => "Display Options", + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + # If you are specifying multiple options you can use an option_group to + # define common parameters. + option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + }; + +=head1 ATTRIBUTES + +These can be provided at object construction, or are generated internally. + +=head2 CONSTRUCTION ONLY + +=over 4 + +=item applicable => sub { ... } + +This is callback is used by the C<applicable()> method. + + option foo => ( + ..., + applicable => sub { + my ($opt, $options) = @_; + ... + return $bool; + }, + ); + +=back + +=head2 READ-ONLY + +=head3 REQUIRED + +=over 4 + +=item $class->new(prefix => 'my_prefix') + +=item $scalar = $opt->prefix() + +A prefix is required. All options have their values inserted into the settings +structure, an instance of L<Test2::Harness::Settings>. The structure is +C<< $settings->PREFIX->OPTION >>. + +If you do not specify a C<name> attribute then the default name will be +C<PREFIX-TITLE>. The name is the main command line argument, so +C<--PREFIX-TITLE> is the default name. + +=item $class->new(type => $type) + +=item $type = $opt->type() + +All options must have a type, if non is specified the default is C<'b'> aka +boolean. + +Here are all the possible types, along with their aliases. You may use the type +character, or any of the aliases to specify that type. + +=over 4 + +=item b bool boolean + +True of false values, will be normalized to 0 or 1 in most cases. + +=item c count counter counting + +Counter, starts at 0 and then increments every time the option is used. + +=item s scalar string number + +Requires an argument which is treated as a scalar value. No type checking is +done by the option itself, though you can check it using C<action> or +C<normalize> callbacks which are documented under those attributes. + +=item m multi multiple list array + +Requires an argument which is treated as a scalar value. Can be used multiple +times. All arguments provided are appended to an array. + +=item d def default + +Argument is optional, scalar when provided. C<--opt=arg> to provide an +argument, C<--opt arg> will not work, C<arg> will be seen as its own item on +the command line. Can be specified without an arg C<--opt> to signify a default +argument should be used (set via the C<action> callback, not the C<default> +attribute which is a default value regardless of if the option is used.) + +Real world example from the debug options (simplified for doc purposes): + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + # New way to specify an auto-fill value for when no =VAL is provided. + # If you do not specify this the default autofill is '1' for legacy support. + autofill => 'VALUE', + + # Old way to autofill a value (default is 1 for auto-fill) + # Using autofill is significantly better. + # You can also use action for additional behavior along with autofill, + # but the default will be your auto-fill value, not '1'. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # $norm will be '1' if option was used without an argument, so we + # just use the provided value when it is not 1'. + return $$slot = $norm unless $norm eq '1'; + + # $norm was 1, so this is our no-arg "default" behavior + + # Do nothing if a value is already set + return if $$slot; + + # Set the default value of 'summary.json' + return $$slot = 'summary.json'; + }, + ); +}; + +=item D multi-def multiple-default list-default array-default + +This is a combination of C<d> and C<m>. You can use the opt multiple times to +list multiple values, and you can call it without args to add a set of +"default" values (not to be confused with THE default attribute, which is used +even if the option never appears on the command line.) + +Real world example (simplified for doc purposes): + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + # New way to specify the auto-fill values. This may be a single scalar, + # or an arrayref. + autofill => [ 'lib', 'blib/lib', 'blib/arch' ], + + # Old way to specify the auto-fill values. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # If no argument was provided use the 'lib', 'blib/lib', and 'blib/arch' defaults. + # If an argument was provided, use it. + push @{$$slot} => ($norm eq '1') ? ('lib', 'blib/lib', 'blib/arch') : ($norm); + }, + ); + +=item h hash + +The hash type. Each time the option is used it is to add a single key/value pair +to the hash. Use an C<=> sign to split the key and value. The option can be +used multiple times. A value is required. + + yath --opt foo=bar --opt baz=bat + +=item H hash-list + +Similar to the 'h' type except the key/value pair expects a comma separated +list for the value, and it will be placed under the key as an arrayef. + + yath --opt foo=a,b,c --opt bar=1,2,3 + +The yath command obove would produce this structure: + + { + foo => ['a', 'b', 'c'], + bar => ['1', '2', '3'], + } + +=back + +=item $class->new(title => 'my_title') + +=item $title = $opt->title() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +If your title is C<'foo-bar_baz'> then your field will be C<'foo_bar_baz'> and +your name will be C<'$PREFIX-foo-bar-baz'>. + +Basically title is used to generate a sane field and/or name if niether are +specified. For field all dashes are changed to underscores. The field is used +as a key in the settings: C<< $settings->prefix->field >>. For the name all +underscores are changed to dashes, if the option is provided by a plugin then +C<'prefix-'> is prepended as well. The name is used for the command line +argument C<'--name'>. + +If you do not want/like the name and field generated from a title then you can +specify a name or title directly. + +=item $class->new(name => 'my-name') + +=item $name = $opt->name() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +This name is used as your primary command line argument. If your name is C<foo> +then your command line argument is C<--foo>. + +=item $class->new(field => 'my_field') + +=item $field = $opt->field() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +The field is used in the settings hash. If your field is C<foo> then your +settings path is C<< $setting->prefix->foo >>. + +=back + +=head3 OPTIONAL + +=over 4 + +=item $class->new(action => sub ...) + +=item $coderef = $opt->action() + + option foo => ( + ..., + action => sub { + my ($prefix, $field_name, $raw_value, $normalized_value, $slot_ref, $settings, $handler, $options) = @_; + + # If no action is specified the following is all that is normally + # done. Having an action means this is not done, so if you want the + # value stored you must call this or similar. + $handler->($slot, $normalized_value); + }, + ); + +=over 4 + +=item $prefix + +The prefix for the option, specified when the option was defined. + +=item $field_name + +The field for the option, specified whent the option was defined. + +=item $raw_value + +The value/argument provided at the command line C<--foo bar> would give us +C<"bar">. This is BEFORE any processing/normalizing is done. + +For options that do not take arguments, or where argumentes are optional and none are provided, this +will be '1'. + +=item $normalized_value + +If a normalize callback was provided this will be the result of putting the +$raw_value through the normalize callback. + +=item $slot_ref + +This is a scalar reference to the settings slot that holds the option value(s). + +The default behavior when no action is specified is usually one of these: + + $$slot_ref = $normalized_value; + push @{$$slot_ref} => $normalized_value; + +However, to save yourself trouble you can use the C<$handler> instead (see below). + +=item $settings + +The L<Test2::Harness::Settings> instance. + +=item $handler + +A callback that "does the right thing" as far as setting the value in the +settings hash. This is what is used when you do not set an action callback. + + $handler->($slot, $normalized_value); + +=item $options + +The L<App::Yath::Options> instance this options belongs to. This is mainly +useful if you have an option that may add even more options (such as the +C<--plugin> option can do). Note that if you do this you should also set the +C<adds_options> attribute to true, if you do not then the options list will not +be refreshed and your new options may not show up. + +=back + +=item $class->new(adds_options => $bool) + +=item $bool = $opt->adds_options() + +If this is true then it means using this option could result in more options +being available (example: Loading a plugin). + +=item $class->new(alt => ['alt1', 'alt2', ...]) + +=item $arrayref = $opt->alt() + +Provide alternative names for the option. These are aliases that can be used to +achieve the same thing on the command line. This is mainly useful for +backcompat if an option is renamed. + +=item $class->new(builds => 'My::Class') + +=item $my_class = $opt->builds() + +If this option is used in the construction of another object (such as the group +it belongs to is composed of options that translate 1-to-1 to fields in another +object to build) then this can be used to specify that. The ultimate effect is +that an exception will be thrown if that class does not have the correct +attribute. This is a safety net to catch errors early if field names change, or +are missing between this representation and the object being composed. + +=item $class->new(category => 'My Category') + +=item $category = $opt->category() + +This is used to sort/display help and POD documentation for your option. If you +do not provide a category it is set to C<'NO CATEGORY - FIX ME'>. The default +value makes sure everyone knows that you do not know what you are doing :-). + +=item $class->new(clear_env_vars => $bool) + +=item $bool = $opt->clear_env_vars() + +This option is only useful when paired with the C<env_vars> attribute. + +Example: + + option foo => ( + ... + env_vars => ['foo', 'bar', 'baz'], + clear_env_vars => 1, + ): + +In this case you are saying option foo can be set to the value of C<$ENV{foo}>, +C<$ENV{bar}>, or C<$ENV{baz}> vars if any are defined. The C<clear_env_vars> +tell it to then delete the environment variables after they are used to set the +option. This is useful if you want to use the env var to set an option, but do +not want any tests to be able to see the env var after it is used to set the +option. + +=item $class->new(default => $scalar) + +=item $class->new(default => sub { return $default }) + +=item $scalar_or_coderef = $opt->default() + +This sets a default value for the field in the settings hash, the default is +set before any command line processing is done, so if the option is never used +in the command line the default value will be there. + +Be sure to use the correct default value for your type. A scalar for 's', an +arrayref for 'm', etc. + +Note, for any non-scalar type you want to use a subref to define the value: + + option foo => ( + ... + type => 'm', + default => sub { [qw/a b c/] }, + ); + +=item $class->new(description => "Fe Fi Fo Fum") + +=item $multiline_string = $opt->description() + +Description of your option. This is used in help output and POD. If you do not +provide a value the default is C<'NO DESCRIPTION - FIX ME'>. + +=item $class->new(env_vars => \@LIST) + +=item $arrayref = $opt->env_vars() + +If set, this should be an arrayref of environment variable names. If any of the +environment variables are defined then the settings will be updated as though +the option was provided onthe command line with that value. + +Example: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + ); + +Then command line: + + FOO="xxx" yath test + +Should be the same as + + yath test --foo "xxx" + +You can also ask to have the environment variables cleared after they are checked: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + clear_env_vars => 1, # This tells yath to clear the env vars after they + are used. + ); + +If you would like the option set to the opposite of the envarinment variable +you can prefix it with a C<'!'> character: + + option foo =>( + ... + env_vars => ['!FOO'], + ); + +In this case these are equivelent: + + FOO=0 yath test + yath test --foo=1 + +Note that this only works when the variable is defined. If C<$ENV{FOO}> is not +defined then the variable is not used. + +=item $class->new(from_command => 'App::Yath::Command::COMMAND') + +=item $cmd_class = $opt->from_command() + +If your option was defined for a specific command this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(from_plugin => 'App::Yath::Plugin::PLUGIN') + +=item $plugin_class = $opt->from_plugin() + +If your option was defined for a specific plugin this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(long_examples => [' foo', '=bar', ...]) + +=item $arrayref = $opt->long_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<--foo bar> would be wrong, you should just do C< bar>. + +=item $class->new(negate => sub { ... }) + +=item $coderef = $opt->negate() + +If you want a custom handler for negation C<--no-OPT> you can provide one here. + + option foo => ( + ... + negate => sub { + my ($prefix, $field, $slot, $settings, $options) = @_; + + ... + }, + ); + +The variables are the same as those in the C<action> callback. + +=item $class->new(normalize => sub { ... }) + +=item $coderef = $opt->normalize() + +The normalize attribute holds a callback sub that takes the raw value as input +and returns the normalized form. + + option foo => ( + ..., + normalize => sub { + my $raw = shift; + + ... + + return $norm; + }, + ); + +=item $class->new(pre_command => $bool) + +=item $bool = $opt->pre_command() + +Options are either command-specific, or pre-command. Pre-command options are +ones yath processes even if it has not determined what comamnd is being used. +Good examples are C<--dev-lib> and C<--plugin>. + + yath --pre-command-opt COMMAND --command-opt + +Most of the time this should be false, very few options qualify as pre-command. + +=item $class->new(pre_process => sub { ... }) + +=item $coderef = $opt->pre_process() + +This is essentially a BEGIN block for options. This callback is called as soon +as the option is parsed from the command line, well before the value is +normalized and added to settings. A good use for this is if your option needs +to inject additional L<App::Yath::Option> instances into the +L<App::Yath::Options> instance. + + option foo => ( + ... + + pre_process => sub { + my %params = @_; + + my $opt = $params{opt}; + my $options = $params{options}; + my $action = $params{action}; + my $type = $params{type}; + my $val = $params{val}; + + ...; + }, + ); + +Explanation of paremeters: + +=over 4 + +=item $params{opt} + +The op instance + +=item $params{options} + +The L<App::Yath::Options> instance. + +=item $params{action} + +A string, usually either "handle" or "handle_negation" + +=item $params{type} + +A string, usually C<"pre-command"> or C<"command ($CLASS)"> where the second +has the command package in the parentheses. + +=item $params{val} + +The value being set, if any. For options that do not take arguments, or in the +case of negation this key may not exist. + +=back + +=item $class->new(short => $single_character_string) + +=item $single_character_string = $opt->short() + +If you want your option to be usable as a short option (single character, +single dash C<-X>) then you can provide the character to use here. If the +option does not require an argument then it can be used along with other +no-argument short options: C<-xyz> would be equivilent to C<-x -y -z>. + +There are only so many single-characters available, so options are restricted +to picking only 1. + +B<Please note:> Yath reserves the right to add any single-character short +options in the main distribution, if they conflict with third party +plugins/commands then the third party must adapt and change its options. As +such it is not recommended to use any short options in third party addons. + +=item $class->new(short_examples => [' foo', ...]) + +=item $arrayref = $opt->short_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<-f bar> would be wrong, you should just do C< bar>. + +This attribute is not used if you do not provide a C<short> attribute. + +=item $class->new(trace => [$package, $file, $line]) + +=item $arrayref = $opt->trace() + +This is almost always auto-populated for you via C<caller()>. It should be an +arrayref with a package, filename and line number. This is used if there is a +conflict between parameter names and/or short options. If such a situation +arises the file/line number of all conflicting options will be reported so it +can be fixed. + +=back + +=head1 METHODS + +=over 4 + +=item $bool = $opt->allows_arg() + +True if arguments can be provided to the option (based on type). This does not +mean the option MUST accept arguments. 'D' type options can accept arguments, +but can also be used without arguments. + +=item $bool = $opt->applicable($options) + +If an option provides an applicability callback this will use it to determine +if the option is applicable given the L<App::Yath::Options> instance. + +If no callback was provided then this returns true. + +=item $character = $opt->canon_type($type_name) + +Given a long alias for an option type this will return the single-character +canonical name. This will return undef for any unknown strings. This will not +translate single character names to themselves, so C<< $opt->canon_type('s') >> +will return undef while C<< $opt->canon_type('string') >> will return C<'s'>. + +=item $val = $opt->get_default() + +This will return the proper default value for the option. If a custom default +was provided it will be returned, otherwise the correct generic default for the +option type will be used. + +Here is a snippet showing the defaults for types: + + # First check env vars and return any values from there + ... + # Then check for a custom default and use it. + ... + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + # All others get undef + return undef; + +=item $val $opt->get_normalized($raw) + +This converts a raw value to a normalized one. If a custom C<normalize> +attribute was set then it will be used, otherwise it is normalized in +accordance to the type. + +This is where booleans are turned into 0 or 1, hashes are split, hash-lists are +split further, etc. + +=item $opt->handle($raw, $settings, $options, $list) + +This method handles setting the value in $settings. You should not normally +need to call this yourself. + +=item $opt->handle_negation() + +This method is used to handle a negated option. You should not normally need to +call this yourself. + +=item @list = $opt->long_args() + +Returns the name and any aliases. + +=item $ref = $opt->option_slot($settings) + +Get the settings->prefix->field reference. This creates the setting field if +necessary. + +=item $bool = $opt->requires_arg() + +Returns true if this option requires an argument when used. + +=item $string = $opt->trace_string() + +return a string like C<"somefile.pm line 42"> based on where the option was +defined. + +=item $bool = $opt->valid_type($character) + +Check if a single character type is valid. + +=back + +=head2 DOCUMENTATION GENERATION + +=over 4 + +=item $string = $opt->cli_docs() + +Get the option documentation in a format that works for the C<yath help +COMMAND> command. + +=item $string = $opt->pod_docs() + +Get the option documentation in POD format. + + =item .... + + .. option details ... + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options.pm b/bad/App/Yath/Options.pm new file mode 100644 index 000000000..42193254d --- /dev/null +++ b/bad/App/Yath/Options.pm @@ -0,0 +1,935 @@ +package App::Yath::Options; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Option(); +use Test2::Harness::Settings(); + +use Test2::Harness::Util::HashBase qw{ + <all <lookup + + <pre_list <cmd_list <post_list + + <post_list_sorted + + <settings + + <args + <command_class + + <pending_pre <pending_cmd <pending_post + + <used_plugins + + <included + + <set_by_cli +}; + +sub import { + my $class = shift; + my $caller = caller(); + + croak "$caller already has an 'options' method" + if defined(&{"$caller\::options"}); + + my @common; + my $instance; + my $options = sub { ($instance //= $class->new()) }; + my $option = sub { ($instance //= $class->new())->_option([caller()], shift(@_), @common ? (%{$common[-1]}) : (), @_) }; + my $include = sub { ($instance //= $class->new())->include_from(@_) }; + + my $post = sub { + my $cb = pop; + my $weight = shift // 0; + my ($applicable) = @_; + + $applicable //= $common[-1]->{applicable} if @common; + + croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE'; + + ($instance //= $class->new())->_post($weight, $applicable, $cb); + }; + + my $group = sub { + my ($set, $sub) = @_; + + my $common = {@common ? (%{$common[-1]}) : (), %$set}; + + if (my $class = $common->{builds}) { + require(mod2file($class)); + } + + push @common => $common; + my $ok = eval { $sub->(); 1 }; + my $err = $@; + pop @common; + + die $err unless $ok; + }; + + { + no strict 'refs'; + *{"$caller\::post"} = $post; + *{"$caller\::option"} = $option; + *{"$caller\::options"} = $options; + *{"$caller\::option_group"} = $group; + *{"$caller\::include_options"} = $include; + } + + return 1; +} + +sub init { + my $self = shift; + + $self->{+ALL} //= []; + $self->{+LOOKUP} //= {}; + + $self->{+USED_PLUGINS} //= []; + + $self->{+PRE_LIST} //= []; + $self->{+CMD_LIST} //= []; + $self->{+POST_LIST} //= []; + + $self->{+SETTINGS} //= Test2::Harness::Settings->new(); + + $self->{+INCLUDED} //= {}; + + $self->{+SET_BY_CLI} //= {}; + + return $self; +} + +sub option { + my $self = shift; + $self->_option([caller()], @_); +} + +sub include { + my $self = shift; + my ($inc) = @_; + + croak "Include must be an instance of ${ \__PACKAGE__ }, got ${ defined($inc) ? \qq['$inc'] : \'undef' }" + unless $inc && blessed($inc) && $inc->isa(__PACKAGE__); + + $self->include_option($_) for @{$inc->all}; + + $self->{+POST_LIST_SORTED} = 0; + push @{$self->{+POST_LIST}} => @{$inc->post_list}; + + return; +} + +sub include_from { + my $self = shift; + + for my $pkg (@_) { + require(mod2file($pkg)) unless $pkg->can('options'); + + next unless $pkg->can('options'); + my $options = $pkg->options or next; + $self->include($options); + + $self->{+INCLUDED}->{$pkg}++; + $self->{+INCLUDED}->{$_}++ for keys %{$options->included}; + } + + return; +} + +sub populate_pre_defaults { + my $self = shift; + + for my $opt (@{$self->_pre_command_options}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub populate_cmd_defaults { + my $self = shift; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + for my $opt (@{$self->_command_options()}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub grab_pre_command_opts { + my $self = shift; + my %config = @_; + + $self->populate_pre_defaults(); + + unshift @{$self->{+PENDING_PRE} //= []} => $self->_grab_opts( + '_pre_command_options', + 'pre-command', + stop_at_non_opt => 1, + passthrough => 1, + %config, + ); +} + +sub process_pre_command_opts { + my $self = shift; + return unless $self->{+PENDING_PRE}; + $self->_process_opts(delete $self->{+PENDING_PRE}); +} + +sub set_command_class { + my $self = shift; + my ($in) = @_; + + croak "Command class has already been set" + if $self->{+COMMAND_CLASS}; + + my $class = blessed($in) || $in; + + croak "Invalid command class: $class" + unless $class->isa('App::Yath::Command'); + + $self->include_from($class) if $class->can('options'); + + return $self->{+COMMAND_CLASS} = $class; +} + +sub set_args { + my $self = shift; + my ($in) = @_; + + croak "'args' has already been set" + if $self->{+ARGS}; + + return $self->{+ARGS} = $in; +} + +sub grab_command_opts { + my $self = shift; + my %config = @_; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + $self->populate_cmd_defaults(); + + push @{$self->{+PENDING_CMD} //= []} => $self->_grab_opts( + '_command_options', + "command (" . $self->{+COMMAND_CLASS}->name . ")", + %config, + ); +} + +sub process_command_opts { + my $self = shift; + return unless $self->{+PENDING_CMD}; + $self->_process_opts(delete $self->{+PENDING_CMD}); +} + +sub process_option_post_actions { + my $self = shift; + my ($cmd) = @_; + + croak "The 'args' attribute has not yet been set" + unless $self->{+ARGS}; + + if ($cmd) { + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + croak "The process_option_post_actions requires an App::Yath::Command instance, got: " . ($cmd // "undef") + unless blessed($cmd) && $cmd->isa('App::Yath::Command'); + + croak "The command '$cmd' dos not match the expected class '$self->{+COMMAND_CLASS}'" + unless blessed($cmd) eq $self->{+COMMAND_CLASS}; + } + + unless ($self->{+POST_LIST_SORTED}++) { + @{$self->{+POST_LIST}} = sort { $a->[0] <=> $b->[0] } @{$self->{+POST_LIST}}; + } + + for my $post (@{$self->{+POST_LIST}}) { + next if $post->[1] && !$post->[1]->($post->[2], $self); + $post->[2]->( + options => $self, + args => $self->{+ARGS}, + settings => $self->{+SETTINGS}, + $cmd ? (command => $cmd) : (), + ); + } +} + +sub _pre_command_options { $_[0]->{+PRE_LIST} } + +sub _command_options { + my $self = shift; + + my $class = $self->{+COMMAND_CLASS} or croak "The 'command_class' attribute has not yet been set"; + + my $cmd = $class->name; + my $cmd_options = $self->{+CMD_LIST} // []; + my $pre_options = $self->{+PRE_LIST} // []; + + return [grep { $_->applicable($self) } @$cmd_options, @$pre_options]; +} + +sub _process_opts { + my $self = shift; + my ($list) = @_; + + while (my $opt_set = shift @$list) { + my ($opt, $meth, @args) = @$opt_set; + $opt->$meth(@args, $self->{+SETTINGS}, $self, $list); + $self->{+SET_BY_CLI}->{$opt->prefix}->{$opt->field}++; + push @{$self->{+USED_PLUGINS}} => $opt->from_plugin if $opt->from_plugin; + } +} + +sub _parse_long_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^--((?:no-)?([^=]+))(=(.*))?$/ or confess "Invalid long option: $arg"; + + #return (main, full, val); + return ($2, $1, $3 ? $4 // '' : undef); +} + +sub _parse_short_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^-([^-])(=)?(.+)?$/ or confess "Invalid short option: $arg"; + + #return (main, remain, assign); + return ($1, $3, $2); +} + +sub _handle_long_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $full, $val) = $self->_parse_long_option($arg); + + my $opt; + if ($opt = $lookup->{long}->{$full}) { + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option --$full requires an argument.\n"; + } + elsif($opt->allows_arg) { + $val //= $opt->autofill // 1; + } + else { + die "Option --$full does not take an argument\n" if defined $val; + $val = 1; + } + + return [$opt, 'handle', $val]; + } + elsif ($opt = $lookup->{long}->{$main}) { + die "Option --$full does not take an argument\n" if defined $val; + return [$opt, 'handle_negation']; + } + + return undef; +} + +sub _handle_short_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $remain, $assign) = $self->_parse_short_option($arg); + + if (my $opt = $lookup->{short}->{$main}) { + if ($opt->allows_arg) { + my $val = $remain; + + $val //= '' if $assign; + + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option -$main requires an argument.\n"; + } + else { + $val //= $opt->autofill // 1; + } + + $val //= 1; + return [$opt, 'handle', $val]; + } + elsif ($assign) { + die "Option -$main does not take an argument\n"; + } + elsif(defined($remain) && length($remain)) { + unshift @$args => "-$remain"; + } + + return [$opt, 'handle', 1]; + } + + return undef; +} + +my %ARG_ENDS = ('--' => 1, '::' => 1); + +sub _grab_opts { + my $self = shift; + my ($opt_fetch, $type, %config) = @_; + + croak "The opt_fetch callback is required" unless $opt_fetch; + croak "The arg type is required" unless $type; + + my $args = $config{args} || $self->{+ARGS} or confess "The 'args' attribute has not yet been set"; + + my $lookup = $self->_build_lookup($self->$opt_fetch()); + + my (@keep_args, @opts); + while (@$args) { + my $arg = shift @$args; + + if ($ARG_ENDS{$arg}) { + push @keep_args => $arg; + last; + } + + if (substr($arg, 0, 1) eq '-') { + my $handler = (substr($arg, 1, 1) eq '-') ? '_handle_long_option' : '_handle_short_option'; + if(my $opt_set = $self->$handler($arg, $lookup, $args)) { + my ($opt, $action, @val) = @$opt_set; + + if (my $pre = $opt->pre_process) { + $pre->( + opt => $opt, + options => $self, + action => $action, + type => $type, + + @val ? (val => $val[0]) : (), + ); + } + + $lookup = $self->_build_lookup($self->$opt_fetch()) + if $opt->adds_options; + + push @opts => $opt_set; + next; + } + elsif (!$config{passthrough}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + } + + if ($config{die_at_non_opt}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + + push @keep_args => $arg; + + last if $config{stop_at_non_opt}; + } + + unshift @$args => @keep_args; + + return @opts; +} + +sub _build_lookup { + my $self = shift; + my ($opts) = @_; + + my $lookup = {long => {}, short => {}}; + + my %seen; + for my $opt (@$opts) { + next if $seen{$opt}++; + + for my $long ($opt->long_args) { + $lookup->{long}->{$long} //= $opt; + } + + my $short = $opt->short or next; + $lookup->{short}->{$short} //= $opt; + } + + return $lookup; +} + +sub _post { + my $self = shift; + my ($weight, $applicable, $cb) = @_; + + $self->{+POST_LIST_SORTED} = 0; + + $weight //= 0; + + push @{$self->{+POST_LIST} //= []} => [$weight, $applicable, $cb]; +} + +sub _option { + my $self = shift; + my ($trace, @spec) = @_; + + my %proto = $self->_parse_option_args(@spec); + + my $opt = App::Yath::Option->new( + trace => $trace, + $self->_parse_option_caller($trace->[0], \%proto), + %proto, + ); + + $self->include_option($opt); +} + +sub include_option { + my $self = shift; + my ($opt) = @_; + + my $trace = $opt->trace or confess "Options must have a trace!"; + + push @{$self->{+ALL}} => $opt; + + my $new = $self->_index_option($opt); + $self->_list_option($opt) if $new; + + return $opt; +} + +sub _parse_option_caller { + my $self = shift; + my ($caller, $proto) = @_; + + my ($from_plugin, $from_command, $from_prefix, $prefix, $is_top); + + $prefix = $proto->{prefix} if exists $proto->{prefix}; + $prefix //= $caller->option_prefix() if $caller->can('option_prefix'); + + if ($caller->isa('App::Yath::Command')) { + $from_command = $caller->name() unless $caller eq 'App::Yath::Command'; + $is_top = 1; + } + elsif ($caller =~ m/App::Yath::Command::([^:]+)::.*Options(?:::.*)?$/) { + $from_command = $1; + $is_top = 1; + } + elsif ($caller eq 'App::Yath') { + $is_top = 1; + } + elsif ($caller =~ m/^(App::Yath::Plugin::([^:]+))$/) { + $from_plugin = $1; + $from_prefix = $2; + + unless (defined $prefix) { + $prefix = $from_prefix; + $prefix =~ s/::.*$//g; + } + } + + $prefix = lc($prefix) if $prefix; + + croak "Could not find an option prefix and option is not top-level ($proto->{title})" + unless $is_top || defined($prefix) || defined($proto->{prefix}); + + return ( + $from_plugin ? (from_plugin => $from_plugin) : (), + $from_command ? (from_command => $from_command) : (), + ($prefix || !$is_top) ? (prefix => $prefix) : (), + ); +} + +sub _parse_option_args { + my $self = shift; + my @spec = @_; + + my %args; + if (@spec == 1) { + my ($title, $type) = $spec[0] =~ m/^([\w-]+)(?:=(.+))?$/ or croak "Invalid option specification: $spec[0]"; + return (title => $title, type => $type); + } + elsif (@spec == 2) { + my ($title, $type) = @spec; + return (title => $title, type => $type); + } + + my $title = shift @spec; + return (title => $title, @spec); +} + +sub _index_option { + my $self = shift; + my ($opt) = @_; + + my $index = $self->{+LOOKUP}; + + my $out = 0; + + for my $n ($opt->name, @{$opt->alt || []}) { + if (my $existing = $index->{$n}) { + next if "$existing" eq "$opt"; + croak "Option '$n' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$n} = $opt; + } + + if (my $short = $opt->short) { + if (my $existing = $index->{$short}) { + return $out if "$existing" eq "$opt"; + croak "Option '$short' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$short} = $opt; + } + + return $out; +} + +sub _list_option { + my $self = shift; + my ($opt) = @_; + + return push @{$self->{+PRE_LIST}} => $opt + if $opt->pre_command; + + push @{$self->{+CMD_LIST}} => $opt; +} + +sub pre_docs { + my $self = shift; + + return $self->_docs($self->_pre_command_options(), @_); +} + +sub cmd_docs { + my $self = shift; + + return unless $self->{+COMMAND_CLASS}; + + return $self->_docs([grep { !$_->pre_command } @{$self->_command_options()}], @_); +} + +my %DOC_FORMATS = ( + 'cli' => [ + 'cli_docs', # Method to call on opt + "\n", # how to join lines + sub { "\n$_[1]" }, # how to render the category + sub { $_[0] =~ s/^/ /mg; "$_[0]\n" }, # transform the value from the opt + sub { }, # add this at the end + ], + 'pod' => [ + 'pod_docs', # Method to call on opt + "\n\n", # how to join lines + sub { ($_[0] ? ("=back") : (), "=head$_[2] $_[1]", "=over 4") }, # how to render the category + sub { $_[0] }, # transform the value from the opt + sub { $_[0] ? ("=back") : () }, # add this at the end + ], +); + +sub _docs { + my $self = shift; + my ($opts, $format, @args) = @_; + + $format //= "UNDEFINED"; + my $fset = $DOC_FORMATS{$format} or croak "Invalid documentation format '$format'"; + my ($fmeth, $join, $fcat, $ftrans, $fend) = @$fset; + + return unless $opts; + return unless @$opts; + + my @opts = sort _doc_sort_ops @$opts; + + my @out; + + my $cat; + for my $opt (@opts) { + if (!$cat || $opt->category ne $cat) { + push @out => $fcat->($cat, $opt->category, @args); + $cat = $opt->category; + } + + my $help = $opt->$fmeth(); + push @out => $ftrans->($help); + } + + push @out => $fend->($cat); + + return join $join => @out; +} + +sub _doc_sort_ops($$) { + my ($a, $b) = @_; + + my $anc = $a->category eq 'NO CATEGORY - FIX ME'; + my $bnc = $b->category eq 'NO CATEGORY - FIX ME'; + + if($anc xor $bnc) { + return 1 if $anc; + return -1; + } + + my $ret = $a->category cmp $b->category; + $ret ||= ($a->prefix || '') cmp ($b->prefix || ''); + $ret ||= $a->field cmp $b->field; + $ret ||= $a->name cmp $b->name; + + return $ret; +} + +sub clear_env { + my $self = shift; + + for my $opt (@{$self->{+ALL}}) { + next unless $opt->clear_env_vars; + my $env = $opt->env_vars or next; + for my $var (@$env) { + $var =~ s/^!//; + delete $ENV{$var}; + } + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options - Tools for defining and tracking yath CLI options. + +=head1 DESCRIPTION + +This class represents a collection of options, and holds the logic for +processing them. This package also exports sugar to help you define options. + +=head1 SYNOPSIS + + package My::Options; + + use App::Yath::Options; + + # This package now has a package instance of options, which can be obtained + # via the options() method. + my $options = __PACKAGE__->options; + + # We can include options from other packages + include_options( + 'Package::With::Options::A', + 'Package::With::Options::B', + ..., + ); + + # Define an option group with some options + option_group { %common_fields } => sub { + + # Define an option + option foo => ( + type => 's', + default => "FOOOOOOO", + category => 'foo', + description => "This is foo" + long_examples => [' value'], + ... + ); + + option bar => ( ... ); + ... + }; + + # Action to call right after options are parsed. + post sub { + my %params = @_; + + ... + }; + +=head1 EXPORTS + +=over 4 + +=item $opts = options() + +=item $opts = $class->options() + +This returns the options instance associated with your package. + +=item include_options(@CLASSES) + +This lets you include options defined in other packages. + +=item option_group \%COMMON_FIELDS => sub { ... } + +An option group is simply a block where all calls to C<option()> will have +common fields added automatically, this makes it easier to define multiple +options that share common fields. Common fields can be overridden inside the +option definition. + +These are both equivalent: + + # Using option group + option_group { category => 'foo', prefix => 'foo' } => sub { + option a => (type => 'b'); + option b => (type => 's'); + }; + + # Not using option group + option a => (type => 'b', category => 'foo', prefix => 'foo'); + option b => (type => 's', category => 'foo', prefix => 'foo'); + +=item option TITLE => %FIELDS + +Define an option. The first argument is the C<title> attribute for the new +option, all other arguments should be attribute/value pairs used to construct +the option. See L<App::Yath::Option> for the documentation of attributes. + +=item post sub { ... } + +=item post $weight => sub { ... } + +C<post> callbacks are run after all command line arguments have been processed. +This is a place to verify the result of several options combined, sanity check, +or even add short-circuit behavior. This is how the C<--help> and +C<--show-opts> options are implemented. + +If no C<$weight> is specified then C<0> is used. C<post> callbacks or sorted +based on weight with higher values being run later. + +=back + +=head1 OPTIONS INSTANCES + +In general you should not be using the options instance directly. Options +instances are mostly an implementation detail that should be treated as a black +box. There are however a few valid reasons to interact with them directly. In +those cases there are a few public attributes/methods you can work with. This +section documents the public interface. + +=head2 ATTRIBUTES + +This section only lists attributes that may be useful to people working with +options instances. There are a lot of internal (to yath) attributes that are +implementation details that are not listed here. Attributes not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $arrayref = $options->all + +Arrayref containing all the L<App::Yath::Option> instances in the options +instance. + +=item $settings = $options->settings + +Get the L<Test2::Harness::Settings> instance. + +=item $arrayref = $options->args + +Get the reference to the list of command line arguments. This list is modified +as arguments are processed, there are no guarentees about what is in here at +any given stage of argument processing. + +=item $class_name = $options->command_class + +If yath has determined what command is being executed this will be populated +with that command class. This will be undefined if the class has not been +determined yet. + +=item $arrayref = $options->used_plugins + +This is a list of all plugins who's options have been used. Plugins may appear +more than once. + +=item $hashref = $options->included + +A hashref where every key is a package who's options have been included into +this options instance. The values are an implementation detail, do not rely on +them. + +=back + +=head2 METHODS + +This section only lists methods that may be useful to people working with +options instances. There are a lot of internal (to yath) methods that are +implementation details that are not listed here. Methods not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $opt = $options->option(%OPTION_ATTRIBUTES) + +This will create a new option with the provided attributes and add it to the +options instance. A C<trace> attribute will be automatically set for you. + +=item $options->include($options_instance) + +This method lets you directly include options from a second instance into the +first. + +=item $options->include_from(@CLASSES) + +This lets you include options from multiple classes that have options defined. + +=item $options->include_option($opt) + +This lets you include a single already defined option instance. + +=item $options->pre_docs($format, @args) + +Get documentation for pre-command options. $format may be 'cli' or 'pod'. + +=item $options->cmd_docs($format, @args) + +Get documentation for command options. $format may be 'cli' or 'pod'. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Collector.pm b/bad/App/Yath/Options/Collector.pm new file mode 100644 index 000000000..e60ed5d85 --- /dev/null +++ b/bad/App/Yath/Options/Collector.pm @@ -0,0 +1,89 @@ +package App::Yath::Options::Collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +option_group {prefix => 'collector', category => "Collector Options"} => sub { + option max_open_jobs => ( + type => 's', + description => 'Maximum number of jobs a collector can process at a time, if more jobs are pending their output will be delayed until the earlier jobs have been processed. (Default: double the -j value)', + long_examples => [' 18'], + short_examples => [' 18'], + ); + + option max_poll_events => ( + type => 's', + description => 'Maximum number of events to poll from a job before jumping to the next job. (Default: 1000)', + default => 1000, + long_examples => [' 1000'], + short_examples => [' 1000'], + ); + + post \&collector_post; +}; + +sub collector_post { + my %params = @_; + my $settings = $params{settings}; + + unless ($settings->collector->max_open_jobs) { + my $j = $settings->runner->job_count // 1; + my $max_open = 2 * $j; + $settings->collector->field(max_open_jobs => $max_open); + } +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Collector - collector options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the collector are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Debug.pm b/bad/App/Yath/Options/Debug.pm new file mode 100644 index 000000000..d728d48bc --- /dev/null +++ b/bad/App/Yath/Options/Debug.pm @@ -0,0 +1,338 @@ +package App::Yath::Options::Debug; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries mod2file clean_path/; + +use Errno qw/EINTR/; + +use App::Yath::Options; + +option_group {prefix => 'debug', category => 'Help and Debugging'} => sub { + post 99999 => \&_post_process_show_opts; + post 99998 => \&_post_process_interactive; + post \&_post_process_version; + post \&_post_process_help; + + option dummy => ( + short => 'd', + description => 'Dummy run, do not actually execute anything', + env_vars => [qw/T2_HARNESS_DUMMY/], + clear_env_vars => 1, + default => 0, + ); + + option procname_prefix => ( + type => 's', + default => '', + description => 'Add a prefix to all proc names (as seen by ps).', + ); + + option keep_dirs => ( + short => 'k', + alt => ['keep_dir'], + description => 'Do not delete directories when done. This is useful if you want to inspect the directories used for various commands.', + default => 0, + ); + + option 'show-opts' => ( + description => 'Exit after showing what yath thinks your options mean', + pre_command => 1, + ); + + option version => ( + short => 'V', + description => "Exit after showing a helpful usage message", + pre_command => 1, + ); + + option help => ( + short => 'h', + description => "exit after showing help information", + ); + + option interactive => ( + short => 'i', + description => 'Use interactive mode, 1 test at a time, stdin forwarded to it', + ); + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + normalize => \&normalize_summary, + action => \&summary_action, + applicable => sub { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; + }, + ); +}; + +sub normalize_summary { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub summary_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('summary.json'); +} + +sub _post_process_help { + my %params = @_; + + return unless $params{settings}->debug->help; + + my $help; + if (my $cmd = $params{command}) { + $help = $cmd->cli_help(%params); + } + else { + $help = __PACKAGE__->cli_help(%params); + } + + if (eval { require IO::Pager; 1 }) { + local $SIG{PIPE} = sub {}; + my $pager = IO::Pager->new(*STDOUT); + $pager->print($help); + } + else { + print $help; + } + + exit 0; +} + +sub _post_process_show_opts { + my %params = @_; + + return unless $params{settings}->debug->show_opts; + + my $settings = $params{settings}; + + print "\nCommand selected: " . $params{command}->name . " (" . ref($params{command}) . ")\n" if $params{command}; + + my $args = $params{args}; + print "\nCommand args: " . join(', ' => @$args) . "\n" if @$args; + + my $out = encode_pretty_json($settings); + + print "\nCurrent command line and config options result in these settings:\n"; + print "$out\n"; + + exit 0; +} + +my $RAN = 0; +sub _post_process_interactive { + return if $RAN++; + my %params = @_; + + return unless $params{settings}->debug->interactive; + + my $settings = $params{settings}; + + my ($fifo); + if ($settings->check_prefix('workspace')) { + my $dir = $settings->workspace->workdir; + $fifo = "$dir/fifo-$$"; + } + else { + require File::Temp; + my $fh; + ($fh, $fifo) = File::Temp::tempfile("YATH-FIFO-$$-XXXXXX", TMPDIR => 1); + close($fh); + unlink($fifo); + } + + ${$settings->debug->vivify_field('fifo')} = $fifo; + + if ($settings->check_prefix('display')) { + $settings->display->field(quiet => 0); + $settings->display->field(verbose => 1) unless $settings->display->verbose; + } + + if ($settings->check_prefix('formatter')) { + $settings->formatter->field(qvf => 0); + } + + if ($settings->check_prefix('run')) { + $settings->run->env_vars->{YATH_INTERACTIVE} = $fifo; + $ENV{YATH_INTERACTIVE} = $fifo; + } + + my $pid = fork() // die "Could not fork: $!"; + if ($pid) { + require Scope::Guard; + require POSIX; + POSIX::mkfifo($fifo, 0700) or die "Failed to make fifo ($fifo): $!"; + my $fh; + + my $cleanup = sub { + close($fh) if $fh; + unlink($fifo) if -e $fifo; + }; + + my $old_int_handler = $SIG{INT}; + my $old_term_handler = $SIG{TERM}; + + $SIG{INT} = sub { $cleanup->('INT'); $old_int_handler->() if ref $old_int_handler; exit 1; }; + $SIG{TERM} = sub { $cleanup->('TERM'); $old_term_handler->() if ref $old_term_handler; exit 1; }; + $SIG{PIPE} = sub { exit 1 }; + + $SIG{CHLD} = sub { + my $res = waitpid($pid, 0); + my $exit = ($? >> 8); + + close($fh) if $fh; + unlink($fifo) if -e $fifo; + + # Forward the exit code from our child + exit($exit); + }; + + for (1 .. 10) { + last if open($fh, '>', $fifo); + die "Could not open fifo ($fifo): $!" unless $! == EINTR; + sleep 1; + } + die "Could not open fifo ($fifo): $!" unless $fh; + + $fh->autoflush(1); + my $guard = Scope::Guard->new($cleanup); + + while(1) { + my $data = <STDIN>; + if (defined($data) && length($data)) { + print $fh $data; + next; + } + + next if defined($data); + + next if kill(0, $pid); + print STDERR "Lost child process $pid\n"; + $cleanup->(); + exit 255; + } + } + + close(STDIN); + open(STDIN, '<', '/dev/null'); + + require Time::HiRes; + while (! -e $fifo) { Time::HiRes::sleep(0.1) }; +} + +sub _post_process_version { + my %params = @_; + + return unless $params{settings}->debug->version; + + require App::Yath; + my $out = <<" EOT"; + +Yath version: $App::Yath::VERSION + +Extended Version Info + EOT + + my $plugin_libs = find_libraries('App::Yath::Plugin::*'); + + my @vers = ( + [perl => $^V], + ['App::Yath' => App::Yath->VERSION], + ( + map { + eval { require(mod2file($_)); 1 } + ? [$_ => $_->VERSION // 'N/A'] + : [$_ => 'N/A'] + } qw/Test2::API Test2::Suite Test::Builder/ + ), + ( + map { + eval { require($plugin_libs->{$_}); 1 } + && [$_ => $_->VERSION // 'N/A'] + } sort keys %$plugin_libs + ), + ); + + $out .= join "\n" => table( + header => [qw/COMPONENT VERSION/], + rows => \@vers, + ); + + print "$out\n\n"; + + exit 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Debug - Debug options for Yath + +=head1 DESCRIPTION + +This is where debug related command line options live. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Display.pm b/bad/App/Yath/Options/Display.pm new file mode 100644 index 000000000..0deaf119f --- /dev/null +++ b/bad/App/Yath/Options/Display.pm @@ -0,0 +1,237 @@ +package App::Yath::Options::Display; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + + option no_wrap => ( + type => 'b', + description => "Do not do fancy text-wrapping, let the terminal handle it", + default => 0, + ); + + option show_times => ( + short => 'T', + description => 'Show the timing data for each job', + ); + + option hide_runner_output => ( + description => 'Hide output from the runner, showing only test output. (See Also truncate_runner_output)', + default => 0, + ); + + option truncate_runner_output => ( + description => 'Only show runner output that was generated after the current command. This is only useful with a persistent runner.', + default => 0, + ); + + option term_width => ( + type => 's', + alt => ['term-size'], + description => 'Alternative to setting $TABLE_TERM_SIZE. Setting this will override the terminal width detection to the number of characters specified.', + long_examples => [' 80', ' 200'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + $ENV{TABLE_TERM_SIZE} = $norm; + }, + ); + + option 'progress' => ( + default => sub { -t STDOUT ? 1 : 0 }, + + description => "Toggle progress indicators. On by default if STDOUT is a TTY. You can use --no-progress to disable the 'events seen' counter and buffered event pre-display", + ); + + option renderers => ( + alt => ['renderer'], + type => 'H', + + description => 'Specify renderers, (Default: "Formatter=Test2"). Use "+" to give a fully qualified module name. Without "+" "Test2::Harness::Renderer::" will be prepended to your argument.', + + long_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + short_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($class, $args) = @$norm; + + $class = "Test2::Harness::Renderer::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + my $ok = eval { require $file; 1 }; + warn "Failed to load renderer '$class': $@" unless $ok; + + $handler->($slot, [$class, $args]); + }, + ); + + post 100 => sub { + my %params = @_; + my $settings = $params{settings}; + + my $display = $settings->display; + my $renderers = $display->renderers; + + my $quiet = $display->quiet; + my $verbose = $display->verbose; + + die "The 'quiet' and 'verbose' options may not be used together.\n" + if $verbose && $quiet; + + if ($quiet) { + delete $renderers->{'Test2::Harness::Renderer::Formatter'}; + @{$renderers->{'@'}} = grep { $_ ne 'Test2::Harness::Renderer::Formatter' } @{$renderers->{'@'}}; + return; + } + + my @args = map { $_ => $settings->formatter->$_ } qw{ + formatter + show_run_info + show_job_info + show_job_launch + show_job_end + }; + + push @args => map { $_ => $settings->display->$_ } qw{ + progress + color + quiet + verbose + show_times + }; + + if (my $formatter_args = $renderers->{'Test2::Harness::Renderer::Formatter'}) { + @$formatter_args = @args unless @$formatter_args; + return; + } + + return if $renderers->{'@'} && @{$renderers->{'@'}}; + + push @{$renderers->{'@'}} => 'Test2::Harness::Renderer::Formatter'; + $renderers->{'Test2::Harness::Renderer::Formatter'} = \@args; + }; +}; + +option_group {prefix => 'formatter', category => "Formatter Options"} => sub { + option formatter => ( + type => 's', + ); + + option 'qvf' => ( + description => '[Q]uiet, but [V]erbose on [F]ailure. Hide all output from tests when they pass, except to say they passed. If a test fails then ALL output from the test is verbosely output.', + ); + + option show_job_end => ( + description => 'Show output when a job ends. (Default: on)', + default => 1, + ); + + option show_job_info => ( + description => 'Show the job configuration when a job starts. (Default: off, unless -vv)', + default => 0, + ); + + option show_job_launch => ( + description => "Show output for the start of a job. (Default: off unless -v)", + default => 0, + ); + + option show_run_info => ( + description => 'Show the run configuration when a run starts. (Default: off, unless -vv)', + default => 0, + ); + + post 90 => sub { + my %params = @_; + my $settings = $params{settings}; + + $settings->formatter->field(formatter => $settings->formatter->qvf ? 'QVF' : 'Test2') + unless defined $settings->formatter->formatter; + + $settings->formatter->field(show_job_launch => 1) + if $settings->display->verbose > 0; + + if ($settings->display->verbose > 1) { + $settings->formatter->field(show_job_info => 1); + $settings->formatter->field(show_run_info => 1); + } + }; +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Display - Display options for Yath. + +=head1 DESCRIPTION + +This is where display options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Finder.pm b/bad/App/Yath/Options/Finder.pm new file mode 100644 index 000000000..58557d346 --- /dev/null +++ b/bad/App/Yath/Options/Finder.pm @@ -0,0 +1,391 @@ +package App::Yath::Options::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +my %RERUN_MODES = ( + all => "Re-Run all tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + failed => "Re-Run failed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + retried => "Re-Run retried tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + passed => "Re-Run passed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + missed => "Run missed tests from a previously aborted/stopped run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", +); + +option_group {prefix => 'finder', category => "Finder Options", builds => 'Test2::Harness::Finder'} => sub { + option finder => ( + type => 's', + default => 'Test2::Harness::Finder', + description => 'Specify what Finder subclass to use when searching for files/processing the file list. Use the "+" prefix to specify a fully qualified namespace, otherwise Test2::Harness::Finder::XXX namespace is assumed.', + long_examples => [' MyFinder', ' +Test2::Harness::Finder::MyFinder'], + pre_command => 1, + adds_options => 1, + pre_process => \&finder_pre_process, + action => \&finder_action, + + builds => undef, # This option is not for the build + ); + + option extension => ( + field => 'extensions', + type => 'm', + alt => ['ext'], + description => 'Specify valid test filename extensions, default: t and t2', + ); + + option search => ( + type => 'm', + + description => 'List of tests and test directories to use instead of the default search paths. Typically these can simply be listed as command line arguments without the --search prefix.', + ); + + option no_long => ( + description => "Do not run tests that have their duration flag set to 'LONG'", + ); + + option only_long => ( + description => "Only run tests that have their duration flag set to 'LONG'", + ); + + option show_changed_files => ( + description => "Print a list of changed files if any are found", + applicable => \&changes_applicable, + ); + + option changed_only => ( + description => "Only search for tests for changed files (Requires a coverage data source, also requires a list of changes either from the --changed option, or a plugin that implements changed_files() or changed_diff())", + applicable => \&changes_applicable, + ); + + option rerun => ( + type => 'd', + description => "Re-Run tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ); + + option rerun_plugin => ( + type => 'm', + description => "What plugin(s) should be used for rerun (will fallback to other plugins if the listed ones decline the value, this is just used ot set an order of priority)", + long_examples => [' Foo', ' +App::Yath::Plugin::Foo'], + ); + + option rerun_modes => ( + alt => ['rerun-mode'], + type => 'm', + description => "Pick which test categories to run", + long_examples => [' failed,missed,...', map {" $_"} sort keys %RERUN_MODES], + ); + + for my $mode (keys %RERUN_MODES) { + option "rerun_$mode" => ( + type => 'd', + description => $RERUN_MODES{$mode}, + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ignore_for_build => 1, + ); + } + + option changed => ( + type => 'm', + description => "Specify one or more files as having been changed.", + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_file => ( + type => 'm', + description => 'Specify one or more files to ignore when looking at changes', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_pattern => ( + type => 'm', + description => 'Ignore files matching this pattern when looking for changes. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_filter_file => ( + type => 'm', + description => 'Specify one or more files to check for changes. Changes to other files will be ignored', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_filter_pattern => ( + type => 'm', + description => 'Specify a pattern for change checking. When only running tests for changed files this will limit which files are checked for changes. Only files that match this pattern will be checked. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_diff => ( + type => 's', + description => "Path to a diff file that should be used to find changed files for use with --changed-only. This must be in the same format as `git diff -W --minimal -U1000000`", + long_examples => [' path/to/diff.diff'], + applicable => \&changes_applicable, + ); + + option changes_plugin => ( + type => 's', + description => "What plugin should be used to detect changed files.", + long_examples => [' Git', ' +App::Yath::Plugin::Git'], + applicable => \&changes_applicable, + ); + + option changes_include_whitespace => ( + type => 'b', + description => "Include changed lines that are whitespace only (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_nonsub => ( + type => 'b', + description => "Exclude changes outside of subroutines (perl files only) (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_loads => ( + type => 'b', + description => "Exclude coverage tests which only load changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_opens => ( + type => 'b', + description => "Exclude coverage tests which only open() changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option maybe_durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option durations_threshold => ( + alt => ['Dt'], + type => 's', + default => undef, + description => "Only fetch duration data if running at least this number of tests. Default (-j value + 1)" + ); + + option exclude_file => ( + field => 'exclude_files', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a file from testing", + ); + + option exclude_pattern => ( + field => 'exclude_patterns', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a pattern from testing, matched using m/\$PATTERN/", + ); + + option exclude_list => ( + field => 'exclude_lists', + type => 'm', + + long_examples => [' file.txt', ' http://example.com/exclusions.txt'], + short_examples => [' file.txt', ' http://example.com/exclusions.txt'], + + description => "Point at a file or url which has a new line separated list of test file names to exclude from testing. Starting a line with a '#' will comment it out (for compatibility with Test2::Aggregate list files).", + ); + + option default_search => ( + type => 'm', + + description => "Specify the default file/dir search. defaults to './t', './t2', and 'test.pl'. The default search is only used if no files were specified at the command line", + ); + + option default_at_search => ( + type => 'm', + + description => "Specify the default file/dir search when 'AUTHOR_TESTING' is set. Defaults to './xt'. The default AT search is only used if no files were specified at the command line", + ); + + post \&_post_process; +}; + +sub _post_process { + my %params = @_; + my $settings = $params{settings}; + my $options = $params{options}; + + my $finder = $settings->finder; + + my $rerun = $finder->rerun; + + for my $mode (sort keys %RERUN_MODES) { + my $val = $finder->remove_field("rerun_$mode") or next; + + push @{$finder->rerun_modes} => $mode; + + next if $val eq '1'; + + $rerun //= $val; + $rerun = $val if $rerun eq '1'; + + die "Multiple runs specified for rerun ($val and $rerun). Please pick one.\n" if $val ne $rerun; + } + + $finder->field(rerun => $rerun); + + my (%seen, @keep); + for my $mode (sort map { split /,/ } @{$finder->rerun_modes}) { + next if $seen{$mode}++; + die "Invalid rerun-mode '$mode'.\n" unless $RERUN_MODES{$mode}; + push @keep => $mode; + } + push @keep => 'all' unless @keep; + + @{$finder->rerun_modes} = @keep; + + if (!defined($settings->finder->durations_threshold)) { + if ($settings->check_prefix('runner')) { + my $jc = $settings->runner->job_count // 1; + $settings->finder->field(durations_threshold => $jc + 1); + } + + $settings->finder->field(durations_threshold => 1); + } + + $settings->finder->field(default_search => ['./t', './t2', 'test.pl']) + unless $settings->finder->default_search && @{$settings->finder->default_search}; + + $settings->finder->field(default_at_search => ['./xt']) + unless $settings->finder->default_at_search && @{$settings->finder->default_at_search}; + + @{$settings->finder->extensions} = ('t', 't2') + unless @{$settings->finder->extensions}; + + s/^\.//g for @{$settings->finder->extensions}; +} + +sub normalize_class { + my ($class) = @_; + + $class = "Test2::Harness::Finder::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + require $file; + + return $class; +} + +sub finder_pre_process { + my %params = @_; + + my $class = $params{val} or return; + + $class = normalize_class($class); + + return unless $class->can('options'); + + $params{options}->include_from($class); +} + +sub finder_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my $class = $norm; + + $class = normalize_class($class); + + if ($class->can('options')) { + $options->populate_pre_defaults(); + $options->populate_cmd_defaults(); + } + + $class->munge_settings($settings, $options) if $class->can('munge_settings'); + + $handler->($slot, $class); +} + +sub changes_applicable { + my ($option, $options) = @_; + + # Cannot use this options with projects + return 0 if $options->command_class && $options->command_class->isa('App::Yath::Command::projects'); + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Finder - Finder options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for discovering test files are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Logging.pm b/bad/App/Yath/Options/Logging.pm new file mode 100644 index 000000000..377ea2012 --- /dev/null +++ b/bad/App/Yath/Options/Logging.pm @@ -0,0 +1,169 @@ +package App::Yath::Options::Logging; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX qw/strftime/; +use Test2::Harness::Util qw/clean_path/; +use File::Spec; + +use App::Yath::Options; + +option_group {prefix => 'logging', category => "Logging Options"} => sub { + option log => ( + short => 'L', + description => 'Turn on logging', + ); + + option log_file_format => ( + alt => ['lff'], + type => 's', + + env_vars => [qw/YATH_LOG_FILE_FORMAT TEST2_HARNESS_LOG_FORMAT/], + default => sub { '%!P%Y-%m-%d_%H:%M:%S_%!U.jsonl' }, + + description => 'Specify the format for automatically-generated log files. Overridden by --log-file, if given. This option implies -L (Default: \$YATH_LOG_FILE_FORMAT, if that is set, or else "%!P%Y-%m-%d~%H:%M:%S~%!U~%!p.jsonl"). This is a string in which percent-escape sequences will be replaced as per POSIX::strftime. The following special escape sequences are also replaced: (%!P : Project name followed by a ~, if a project is defined, otherwise empty string) (%!U : the unique test run ID) (%!p : the process ID) (%!S : the number of seconds since local midnight UTC)', + + ); + + option bzip2 => ( + short => 'B', + alt => ['bz2', 'bzip2_log'], + description => 'Use bzip2 compression when writing the log. This option implies -L. The .bz2 prefix is added to log file name for you', + ); + + option gzip => ( + short => 'G', + alt => ['gz', 'gzip_log'], + description => 'Use gzip compression when writing the log. This option implies -L. The .gz prefix is added to log file name for you', + ); + + option log_dir => ( + type => 's', + normalize => \&clean_path, + description => 'Specify a log directory. Will fall back to the system temp dir.', + ); + + option log_file => ( + short => 'F', + type => 's', + normalize => \&clean_path, + description => "Specify the name of the log file. This option implies -L.", + ); + + post \&post_process; +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + my $logging = $settings->logging; + + die "You cannot specify both bzip2-log and gzip-log\n" if $logging->bzip2 && $logging->gzip; + + return unless $logging->log || $logging->bzip2 || $logging->gzip || $logging->log_file; + + # We want to keep the log and put it in a findable location + $logging->field(log => 1); + + unless ($logging->log_file) { + my $log_dir = $logging->log_dir // ($settings->check_prefix('workspace') ? $settings->workspace->tmp_dir : File::Spec->tmpdir); + + mkdir($log_dir) or die "Could not create dir '$log_dir': $!" + unless -d $log_dir; + + my $format = $logging->log_file_format; + my $filename = expand_log_file_format($format, $settings); + $logging->field(log_file => clean_path(File::Spec->catfile($log_dir, $filename))); + } + + my $log_file = $logging->log_file; + $log_file =~ s{/+$}{}g; + $log_file =~ s/\.(gz|bz2)$//; + $log_file =~ s/\.jsonl?$//; + $log_file .= "\.jsonl"; + $log_file .= "\.bz2" if $logging->bzip2; + $log_file .= "\.gz" if $logging->gzip; + $logging->field(log_file => $log_file); +} + +sub time_for_strftime { time() } + +sub expand_log_file_format { + my ($pattern, $settings) = @_; + my $before = $pattern; + $pattern =~ s{%!(\w)}{expand($1, $settings)}ge; + my $res = strftime($pattern, localtime(time_for_strftime())); + return $res; +} + +sub expand { + my ($letter, $settings) = @_; + # This could be driven by a hash, but for now if-else is easiest + if ($letter eq "U") { return $settings->run->run_id } + elsif ($letter eq "p") { return $$ } + elsif ($letter eq "P") { + my $project = $settings->harness->project // return ""; + return $project . "~"; + } + elsif ($letter eq "S") { + # Number of seconds since midnight + my ($s, $m, $h) = (localtime(time_for_strftime()))[0, 1, 2]; + return sprintf("%05d", $s + 60 * $m + 3600 * $h); + } + else { + # unrecognized `%!x` expansion. Should we warn? Die? + return "%!$letter"; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Logging - Logging options for yath + +=head1 DESCRIPTION + +This is where the command line options for logging are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Persist.pm b/bad/App/Yath/Options/Persist.pm new file mode 100644 index 000000000..c73e306a7 --- /dev/null +++ b/bad/App/Yath/Options/Persist.pm @@ -0,0 +1,68 @@ +package App::Yath::Options::Persist; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; +use Test2::Harness::Util qw/clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option daemon => ( + description => 'Start the runner as a daemon (Default: True)', + default => 1, + ); +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Persist - Persistent Runner options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the persistent runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/PreCommand.pm b/bad/App/Yath/Options/PreCommand.pm new file mode 100644 index 000000000..a99c8f387 --- /dev/null +++ b/bad/App/Yath/Options/PreCommand.pm @@ -0,0 +1,177 @@ +package App::Yath::Options::PreCommand; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/mod2file clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'harness', pre_command => 1} => sub { + option plugins => ( + type => 'm', + short => 'p', + alt => ['plugin'], + + category => 'Plugins', + long_examples => [' PLUGIN', ' +App::Yath::Plugin::PLUGIN', ' PLUGIN=arg1,arg2,...'], + short_examples => ['PLUGIN'], + description => 'Load a yath plugin.', + + action => \&plugin_action, + ); + + option no_scan_plugins => ( + type => 'b', + + category => 'Plugins', + description => 'Normally yath scans for and loads all App::Yath::Plugin::* modules in order to bring in command-line options they may provide. This flag will disable that. This is useful if you have a naughty plugin that is loading other modules when it should not.', + ); + + option project => ( + type => 's', + alt => ['project-name'], + category => 'Environment', + description => 'This lets you provide a label for your current project/codebase. This is best used in a .yath.rc file. This is necessary for a persistent runner.', + ); + + option persist_dir => ( + type => 's', + category => 'Environment', + description => 'Where to find persistence files.', + normalize => \&clean_path, + ); + + option persist_file => ( + type => 's', + category => 'Environment', + alt => ['pfile'], + normalize => \&clean_path, + description => "Where to find the persistence file. The default is /{system-tempdir}/project-yath-persist.json. If no project is specified then it will fall back to the current directory. If the current directory is not writable it will default to /tmp/yath-persist.json which limits you to one persistent runner on your system.", + ); + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + normalize => \&normalize_dev_libs, + action => \&dev_libs_action, + ); + + post \&post_process; +}; + +sub plugin_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my ($class, $args) = split /=/, $norm, 2; + $args = [split ',', $args] if $args; + + $class = "App::Yath::Plugin::$class" + unless $class =~ s/^\+//; + + return if grep { $class eq (ref($_) || $_) } @{$settings->harness->plugins}; + + my $file = mod2file($class); + require $file; + + $options->include_from($class) if $class->can('options'); + + my $plugin = $class->can('new') ? $class->new(@{$args // []}) : $class; + + $handler->($slot, $plugin); +} + +sub normalize_dev_libs { + my $val = shift; + + return $val if $val eq '1'; + + return clean_path($val); +} + +sub dev_libs_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my %seen = map { $_ => 1 } @{$$slot}; + + my @new = grep { !$seen{$_}++ } ($norm eq '1') ? (map { clean_path($_) } 'lib', 'blib/lib', 'blib/arch') : ($norm); + + return unless @new; + + warn <<" EOT" for @new; +dev-lib '$_' added to \@INC late, it is possible some yath libraries were already loaded from other paths. +(Maybe you need to move the -D or --dev-lib argument(s) to be earlier in your command line or config file?) + EOT + + unshift @INC => @new; + unshift @{$$slot} => @new; +} + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->harness->field(persist_file => find_pfile($settings, vivify => 1, no_checks => 1)) + unless defined $settings->harness->persist_file; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::PreCommand - Options for yath before command is specified. + +=head1 DESCRIPTION + +This is qhere many pe-commnd options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Run.pm b/bad/App/Yath/Options/Run.pm new file mode 100644 index 000000000..8d735bb4f --- /dev/null +++ b/bad/App/Yath/Options/Run.pm @@ -0,0 +1,231 @@ +package App::Yath::Options::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Options; + +option_group {prefix => 'run', category => "Run Options", builds => 'Test2::Harness::Run'} => sub { + post \&post_process; + + option link => ( + field => 'links', + type => 'm', + long_examples => [ + " 'https://travis.work/builds/42'", + " 'https://jenkins.work/job/42'", + " 'https://buildbot.work/builders/foo/builds/42'", + ], + description => "Provide one or more links people can follow to see more about this run." + ); + + option test_args => ( + type => 'm', + description => 'Arguments to pass in as @ARGV for all tests that are run. These can be provided easier using the \'::\' argument separator.' + ); + + option input => ( + type => 's', + description => 'Input string to be used as standard input for ALL tests. See also: --input-file', + ); + + option input_file => ( + type => 's', + description => 'Use the specified file as standard input to ALL tests', + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + die "Input file not found: $norm\n" unless -f $norm; + if ($settings->run->input) { + warn "Input file is overriding another source of input.\n"; + $settings->run->field(input => undef); + } + + $handler->($slot, $norm); + }, + ); + + option dbi_profiling => ( + type => 'b', + description => "Use Test2::Plugin::DBIProfile to collect database profiling data", + ); + + option author_testing => ( + short => 'A', + description => 'This will set the AUTHOR_TESTING environment to true', + ); + + option use_stream => ( + name => 'stream', + description => "Use the stream formatter (default is on)", + default => 1, + ); + + option tap => ( + field => 'use_stream', + alt => ['TAP', '--no-stream'], + normalize => sub { $_[0] ? 0 : 1 }, + description => "The TAP format is lossy and clunky. Test2::Harness normally uses a newer streaming format to receive test results. There are old/legacy tests where this causes problems, in which case setting --TAP or --no-stream can help." + ); + + option fields => ( + type => 'm', + short => 'f', + long_examples => [' name:details', ' JSON_STRING'], + short_examples => [' name:details', ' JSON_STRING'], + description => "Add custom data to the harness run", + action => \&fields_action, + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables to set when each test is run.', + ); + + option run_id => ( + alt => ['id'], + description => 'Set a specific run-id. (Default: a UUID)', + default => \&gen_uuid, + ); + + option load => ( + type => 'm', + short => 'm', + alt => ['load-module'], + description => 'Load a module in each test (after fork). The "import" method is not called.', + ); + + option load_import => ( + type => 'H', + short => 'M', + alt => ['loadim'], + + long_examples => [' Module', ' Module=import_arg1,arg2,...'], + short_examples => [' Module', ' Module=import_arg1,arg2,...'], + + description => 'Load a module in each test (after fork). Import is called.', + ); + + option event_uuids => ( + default => 1, + alt => ['uuids'], + description => 'Use Test2::Plugin::UUID inside tests (default: on)', + ); + + option mem_usage => ( + default => 1, + description => 'Use Test2::Plugin::MemUsage inside tests (default: on)', + ); + + option io_events => ( + default => 0, + description => 'Use Test2::Plugin::IOEvents inside tests to turn all prints into test2 events (default: off)', + ); + + option retry => ( + default => 0, + short => 'r', + type => 's', + description => 'Run any jobs that failed a second time. NOTE: --retry=1 means failing tests will be attempted twice!', + ); + + option retry_isolated => ( + default => 0, + alt => ['retry-iso'], + type => 'b', + description => 'If true then any job retries will be done in isolation (as though -j1 was set)', + ); +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->run->env_vars->{AUTHOR_TESTING} = 1 if $settings->run->author_testing; + + if ($settings->run->dbi_profiling) { + eval { require Test2::Plugin::DBIProfile; 1 } or die "Could not enable DBI profiling, could not load 'Test2::Plugin::DBIProfile': $@"; + push @{$settings->run->load_import->{'@'}} => 'Test2::Plugin::DBIProfile'; + $settings->run->load_import->{'Test2::Plugin::DBIProfile'} = []; + } +} + +sub fields_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my $fields = ${$slot} //= []; + + if ($norm =~ m/^{/) { + my $field = {}; + my $ok = eval { $field = Test2::Harness::Util::JSON::decode_json($norm); 1 }; + chomp(my $error = $@ // ''); + + die "Error parsing field specification '$field': $error\n" unless $ok; + die "Fields must have a 'name' key (error in '$raw')\n" unless $field->{name}; + die "Fields must habe a 'details' key (error in '$raw')\n" unless $field->{details}; + + return push @$fields => $field; + } + elsif ($norm =~ m/([^:]+):([^:]+)/) { + return push @$fields => {name => $1, details => $2}; + } + + die "'$raw' is not a valid field specification.\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Run - Run options for Yath. + +=head1 DESCRIPTION + +This is where command lines options for a single test run are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Runner.pm b/bad/App/Yath/Options/Runner.pm new file mode 100644 index 000000000..e8bb5feff --- /dev/null +++ b/bad/App/Yath/Options/Runner.pm @@ -0,0 +1,362 @@ +package App::Yath::Options::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use List::Util qw/min/; +use Test2::Util qw/IS_WIN32/; +use App::Yath::Util qw/find_in_updir/; +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use File::Spec; + +use App::Yath::Options; + +my $DEFAULT_COVER_ARGS = '-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option use_fork => ( + alt => ['fork'], + description => "(default: on, except on windows) Normally tests are run by forking, which allows for features like preloading. This will turn off the behavior globally (which is not compatible with preloading). This is slower, it is better to tag misbehaving tests with the '# HARNESS-NO-PRELOAD' comment in their header to disable forking only for those tests.", + env_vars => [qw/!T2_NO_FORK T2_HARNESS_FORK !T2_HARNESS_NO_FORK YATH_FORK !YATH_NO_FORK/], + default => sub { + return 0 if IS_WIN32; + return 1; + }, + ); + + option abort_on_bail => ( + type => 'b', + default => 1, + description => "Abort all testing if a bail-out is encountered (default: on)", + ); + + option use_timeout => ( + alt => ['timeout'], + description => "(default: on) Enable/disable timeouts", + default => 1, + ); + + option shared_jobs_config => ( + type => 's', + description => 'Where to look for a shared slot config file. If a filename with no path is provided yath will search the current and all parent directories for the name.', + default => '.sharedjobslots.yml', + long_examples => [ ' .sharedjobslots.yml', ' relative/path/.sharedjobslots.yml', ' /absolute/path/.sharedjobslots.yml' ], + ); + + post \&jobs_post_process; + option job_count => ( + type => 's', + short => 'j', + alt => ['jobs'], + description => 'Set the number of concurrent jobs to run. Add a :# if you also wish to designate multiple slots per test. 8:2 means 8 slots, but each test gets 2 slots, so 4 tests run concurrently. Tests can find their concurrency assignemnt in the "T2_HARNESS_MY_JOB_CONCURRENCY" environment variable.', + env_vars => [qw/YATH_JOB_COUNT T2_HARNESS_JOB_COUNT HARNESS_JOB_COUNT/], + clear_env_vars => 1, + long_examples => [' 4', ' 8:2'], + short_examples => ['4', '8:2'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($jobs, $slots) = split /:/, $norm; + + $$slot = $jobs; + + $settings->runner->slots_per_job($slots) if defined $slots; + + fix_job_resources($settings); + }, + ); + + option slots_per_job => ( + type => 's', + short => 'x', + description => "This sets the number of slots each job will use (default 1). This is normally set by the ':#' in '-j#:#'.", + env_vars => ['T2_HARNESS_JOB_CONCURRENCY'], + clear_env_vars => 1, + long_examples => [' 2'], + short_examples => ['2'], + ); + + option dump_depmap => ( + type => 'b', + description => "When using staged preload, dump the depmap for each stage as json files", + default => 0, + ); + + option includes => ( + name => 'include', + short => 'I', + type => 'm', + description => "Add a directory to your include paths", + ); + + option resources => ( + name => 'resource', + short => 'R', + type => 'm', + description => "Use a resource module to assign resource assignments to individual tests", + long_examples => [' Port', ' +Test2::Harness::Runner::Resource::Port'], + short_examples => [' Port'], + + normalize => sub { + my $val = shift; + + $val = "Test2::Harness::Runner::Resource::$val" + unless $val =~ s/^\+//; + + return $val; + }, + ); + + option tlib => ( + description => "(Default: off) Include 't/lib' in your module path", + default => 0, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => File::Spec->catdir('t', 'lib'); + }, + ); + + option lib => ( + short => 'l', + description => "(Default: include if it exists) Include 'lib' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => 'lib'; + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option blib => ( + short => 'b', + description => "(Default: include if it exists) Include 'blib/lib' and 'blib/arch' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + push @{$settings->runner->includes} => ( + File::Spec->catdir('blib', 'lib'), + File::Spec->catdir('blib', 'arch'), + ); + + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option unsafe_inc => ( + description => "perl is removing '.' from \@INC as a security concern. This option keeps things from breaking for now.", + env_vars => [qw/PERL_USE_UNSAFE_INC/], + default => 0, + ); + + option preloads => ( + type => 'm', + alt => ['preload'], + short => 'P', + description => 'Preload a module before running tests', + ); + + option preload_threshold => ( + short => 'W', + alt => ['Pt'], + type => 's', + default => 0, + description => "Only do preload if at least N tests are going to be run. In some cases a full preload takes longer than simply running the tests, this lets you specify a minimum number of test jobs that will be run for preload to happen. This has no effect for a persistent runner. The default is 0, and it means always preload." + ); + + option nytprof => ( + type => 'b', + description => "Use Devel::NYTProf on tests. This will set addpid=1 for you. This works with or without fork.", + long_examples => [''], + ); + + post \&cover_post_process; + option cover => ( + type => 'd', + description => "Use Devel::Cover to calculate test coverage. This disables forking. If no args are specified the following are used: $DEFAULT_COVER_ARGS", + long_examples => ['', '=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'], + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = $DEFAULT_COVER_ARGS if $norm eq '1'; + return $$slot = $norm; + }, + ); + + option switch => ( + field => 'switches', + short => 'S', + type => 'm', + description => 'Pass the specified switch to perl for each test. This is not compatible with preload.', + ); + + option event_timeout => ( + alt => ['et'], + + type => 's', + default => 60, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Kill test if no output is received within timeout period. (Default: 60 seconds). Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis. This prevents a hung test from running forever.', + ); + + option post_exit_timeout => ( + alt => ['pet'], + + type => 's', + default => 15, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Stop waiting post-exit after the timeout period. (Default: 15 seconds) Some tests fork and allow the parent to exit before writing all their output. If Test2::Harness detects an incomplete plan after the test exits it will monitor for more events until the timeout period. Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis.' + ); + + option runner_id => ( + type => 's', + default => sub { gen_uuid() }, + description => 'Runner ID (usually a generated uuid)', + ); +}; + +sub jobs_post_process { + my %params = @_; + my $settings = $params{settings}; + + my $runner = $settings->runner or return; + + fix_job_resources($settings); + + $ENV{T2_HARNESS_MY_JOB_COUNT} = $runner->job_count; + $ENV{T2_HARNESS_MY_MAX_JOB_CONCURRENCY} = $runner->slots_per_job; +} + +sub fix_job_resources { + my ($settings) = @_; + + my $runner = $settings->runner; + + require Test2::Harness::Runner::Resource::SharedJobSlots::Config; + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + + my %found; + for my $r (@{$runner->resources}) { + require(mod2file($r)); + next unless $r->job_limiter; + $found{$r}++; + } + + if ($sconf && !$found{'Test2::Harness::Runner::Resource::SharedJobSlots'}) { + if (delete $found{'Test2::Harness::Runner::Resource::JobCount'}) { + @{$settings->runner->resources} = grep { $_ ne 'Test2::Harness::Runner::Resource::JobCount' } @{$runner->resources}; + } + + if (!keys %found) { + require Test2::Harness::Runner::Resource::SharedJobSlots; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::SharedJobSlots'; + $found{'Test2::Harness::Runner::Resource::SharedJobSlots'}++; + } + } + elsif (!keys %found) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + if ($found{'Test2::Harness::Runner::Resource::SharedJobSlots'} && $sconf) { + $runner->field(job_count => $sconf->default_slots_per_run || $sconf->max_slots_per_run) if $runner && !$runner->job_count; + $runner->field(slots_per_job => $sconf->default_slots_per_job || $sconf->max_slots_per_job) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "Requested job count ($run_slots) exceeds the system shared limit (" . $sconf->max_slots_per_run . ").\n" + if $run_slots > $sconf->max_slots_per_run; + + die "Requested job concurrency ($job_slots) exceeds the system shared limit (" . $sconf->max_slots_per_job . ").\n" + if $job_slots > $sconf->max_slots_per_job; + } + + $runner->field(job_count => 1) if $runner && !$runner->job_count; + $runner->field(slots_per_job => 1) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "The slots_per_job (set to $job_slots) must not be larger than the job_count (set to $run_slots).\n" if $job_slots > $run_slots; +} + +sub cover_post_process { + my %params = @_; + my $settings = $params{settings}; + + if ($ENV{T2_DEVEL_COVER} && !$settings->runner->cover) { + $settings->runner->field(cover => $ENV{T2_DEVEL_COVER} eq '1' ? $ENV{T2_DEVEL_COVER} : $DEFAULT_COVER_ARGS); + } + + return unless $settings->runner->cover; + + # For nested things + $ENV{T2_NO_FORK} = 1; + $ENV{T2_DEVEL_COVER} = $settings->runner->cover; + $settings->runner->field(use_fork => 0); + + return unless $settings->check_prefix('run'); + push @{$settings->run->load_import->{'@'}} => 'Devel::Cover'; + $settings->run->load_import->{'Devel::Cover'} = [split(/,/, $settings->runner->cover)]; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Runner - Runner options for Yath. + +=head1 DESCRIPTION + +This is where command line options for the runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/App/Yath/Options/Workspace.pm b/bad/App/Yath/Options/Workspace.pm new file mode 100644 index 000000000..752306e66 --- /dev/null +++ b/bad/App/Yath/Options/Workspace.pm @@ -0,0 +1,115 @@ +package App::Yath::Options::Workspace; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); +use File::Path qw/remove_tree/; +use File::Temp qw/tempdir/; + +use Test2::Harness::Util qw/clean_path chmod_tmp/; + +use App::Yath::Options; + +option_group {prefix => 'workspace', category => "Workspace Options"} => sub { + option tmp_dir => ( + type => 's', + short => 't', + alt => ['tmpdir'], + description => 'Use a specific temp directory (Default: use system temp dir)', + env_vars => [qw/T2_HARNESS_TEMP_DIR YATH_TEMP_DIR TMPDIR TEMPDIR TMP_DIR TEMP_DIR/], + default => sub { File::Spec->tmpdir }, + ); + + option workdir => ( + type => 's', + short => 'w', + description => 'Set the work directory (Default: new temp directory)', + env_vars => [qw/T2_WORKDIR YATH_WORKDIR/], + clear_env_vars => 1, + normalize => \&clean_path, + ); + + option clear => ( + short => 'C', + description => 'Clear the work directory if it is not already empty', + ); + + post sub { + my %params = @_; + my $settings = $params{settings}; + + if (my $workdir = $settings->workspace->workdir) { + if (-d $workdir) { + remove_tree($workdir, {safe => 1, keep_root => 1}) if $settings->workspace->clear; + } + else { + mkdir($workdir) or die "Could not create workdir: $!"; + chmod_tmp($workdir); + } + + return; + } + + my $project = $settings->harness->project; + my $template = join '-' => ( "yath", $$, "XXXXXX"); + + my $tmpdir = tempdir( + $template, + DIR => $settings->workspace->tmp_dir, + CLEANUP => !($settings->debug->keep_dirs || $params{command}->always_keep_dir), + ); + chmod_tmp($tmpdir); + + $settings->workspace->field(workdir => $tmpdir); + }; +}; + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Workspace - Options for specifying the yath work dir. + +=head1 DESCRIPTION + +Options regarding the yath working directory. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib/App/Yath/Plugin.pm b/bad/App/Yath/Plugin.pm similarity index 100% rename from lib/App/Yath/Plugin.pm rename to bad/App/Yath/Plugin.pm diff --git a/lib/App/Yath/Plugin/Cover.pm b/bad/App/Yath/Plugin/Cover.pm similarity index 100% rename from lib/App/Yath/Plugin/Cover.pm rename to bad/App/Yath/Plugin/Cover.pm diff --git a/lib/App/Yath/Plugin/Git.pm b/bad/App/Yath/Plugin/Git.pm similarity index 100% rename from lib/App/Yath/Plugin/Git.pm rename to bad/App/Yath/Plugin/Git.pm diff --git a/lib/App/Yath/Plugin/Notify.pm b/bad/App/Yath/Plugin/Notify.pm similarity index 100% rename from lib/App/Yath/Plugin/Notify.pm rename to bad/App/Yath/Plugin/Notify.pm diff --git a/lib/App/Yath/Plugin/SysInfo.pm b/bad/App/Yath/Plugin/SysInfo.pm similarity index 100% rename from lib/App/Yath/Plugin/SysInfo.pm rename to bad/App/Yath/Plugin/SysInfo.pm diff --git a/lib/App/Yath/Plugin/YathUI.pm b/bad/App/Yath/Plugin/YathUI.pm similarity index 100% rename from lib/App/Yath/Plugin/YathUI.pm rename to bad/App/Yath/Plugin/YathUI.pm diff --git a/lib/App/Yath/Tester.pm b/bad/App/Yath/Tester.pm similarity index 100% rename from lib/App/Yath/Tester.pm rename to bad/App/Yath/Tester.pm diff --git a/bad/App/Yath/Util.pm b/bad/App/Yath/Util.pm new file mode 100644 index 000000000..9d0a96ca1 --- /dev/null +++ b/bad/App/Yath/Util.pm @@ -0,0 +1,369 @@ +package App::Yath::Util; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Test2::Harness::Util qw/clean_path/; +use Test2::Harness::Util::File::JSON; + +use Cwd qw/realpath/; +use Importer Importer => 'import'; +use Config qw/%Config/; +use Carp qw/croak/; + +our @EXPORT_OK = qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath +}; + +sub find_yath { + return $App::Yath::Script::SCRIPT if defined $App::Yath::Script::SCRIPT; + + if (-d 'scripts') { + my $script = File::Spec->catfile('scripts', 'yath'); + return $App::Yath::Script::SCRIPT = clean_path($script) if -e $script && -x $script; + } + + my @keys = qw{ + bin binexp initialinstalllocation installbin installscript + installsitebin installsitescript installusrbinperl installvendorbin + scriptdir scriptdirexp sitebin sitebinexp sitescript sitescriptexp + vendorbin vendorbinexp + }; + + my %seen; + for my $path (@Config{@keys}) { + next unless $path; + next if $seen{$path}++; + + my $script = File::Spec->catfile($path, 'yath'); + next unless -f $script && -x $script; + + $App::Yath::Script::SCRIPT = $script = clean_path($script); + return $script; + } + + die "Could not find yath in Config paths"; +} + +sub isolate_stdout { + # Make $fh point at STDOUT, it is our primary output + open(my $fh, '>&', STDOUT) or die "Could not clone STDOUT: $!"; + select $fh; + $| = 1; + + # re-open STDOUT redirected to STDERR + open(STDOUT, '>&', STDERR) or die "Could not redirect STDOUT to STDERR: $!"; + select STDOUT; + $| = 1; + + # Yes, we want to keep STDERR selected + select STDERR; + $| = 1; + + return $fh; +} + +sub is_generated_test_pl { + my ($file) = @_; + + open(my $fh, '<', $file) or die "Could not open '$file': $!"; + + my $count = 0; + while (my $line = <$fh>) { + last if $count++ > 5; + next unless $line =~ m/^# THIS IS A GENERATED YATH RUNNER TEST$/; + return 1; + } + + return 0; +} + + +sub find_in_updir { + my $path = shift; + return clean_path($path) if -f $path; + + my %seen; + while(1) { + $path = File::Spec->catdir('..', $path); + my $check = eval { realpath(File::Spec->rel2abs($path)) }; + last unless $check; + last if $seen{$check}++; + return $check if -f $check; + } + + return; +} + +sub _find_pfile { + my ($settings, %params) = @_; + + croak "Settings is a required argument" unless $settings; + + # First do the entire search without vivify + if ($params{vivify}) { + my $found = find_pfile($settings, %params, vivify => 0); + return $found if $found; + } + + my $yath = $settings->harness; + + if (my $pfile = $yath->persist_file) { + return $pfile if -f $pfile || $params{vivify}; + + return; # Specified, but not found and no vivify + } + + my $basename = "yath-persist.json"; + my $user = $ENV{USER}; + my $hostname = hostname(); + my $project = $yath->project; + + my @names = ($basename); + @names = (@names, map { "$project-$_" } @names) if $project; + @names = (@names, map { "$hostname-$_" } @names) if $hostname; + @names = (@names, map { "$user-$_" } @names) if $user; + @names = reverse map { ".$_" } @names; + + my $set_dir = $yath->persist_dir // $ENV{YATH_PERSISTENCE_DIR}; + my $dir = $set_dir // $ENV{TMPDIR} // $ENV{TEMPDIR} // File::Spec->tmpdir; + + # If a dir was specified, or if the current dir is not writable then we must use $dir/$name + if ($project || $set_dir || !-w '.') { + for my $name (@names) { + my $pfile = clean_path(File::Spec->catfile($dir, $name)); + return $pfile if -f $pfile; + } + + return clean_path(File::Spec->catfile($dir, $names[0])) if $params{vivify}; + return; # Not found + } + + # Fall back to using the current dir (which must be writable) + for my $name (@names) { + my $pfile = find_in_updir($name); + return $pfile if $pfile && -f $pfile; + } + + # Creating it here! + return clean_path(File::Spec->catfile('.', $names[0])) if $params{vivify}; + + # Nope, nothing. + return; +} + +sub fit_to_width { + my ($width, $join, $text) = @_; + + my @parts = ref($text) ? @$text : split /\s+/, $text; + + my @out; + + my $line = ""; + for my $part (@parts) { + my $new = $line ? "$line$join$part" : $part; + + if ($line && length($new) > $width) { + push @out => $line; + $line = $part; + } + else { + $line = $new; + } + } + push @out => $line if $line; + + return join "\n" => @out; +} + +my $SEEN_ERROR = 0; +sub find_pfile { + my ($settings, %params) = @_; + my $pfile = _find_pfile($settings, %params) or return; + + return $pfile unless -e $pfile; + return $pfile if $params{no_checks}; + return $pfile if $SEEN_ERROR; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + + $data->{version} //= ''; + $data->{hostname} //= ''; + $data->{user} //= ''; + $data->{pid} //= ''; + $data->{dir} //= ''; + + my $hostname = hostname(); + my $user = $ENV{USER}; + + my @bad; + + push @bad => "** Version mismatch, persistent runner is version $data->{version}, current is version $VERSION. **" + if $data->{version} ne $VERSION; + + push @bad => "** Hostname mismatch, persistent runner hostname is '$data->{hostname}', current hostname is '$hostname'. **" + if $data->{hostname} ne $hostname; + + push @bad => "** User mismatch, persistent runner user is '$data->{user}', current user is '$user'. **" + if $data->{user} ne $user; + + push @bad => "** Workdir missing, persistent runner is supposed to be at '$data->{dir}', but it does not exist. **" + unless -d $data->{dir}; + + push @bad => "** PID not running, persistent runner is supposed to be running with PID '$data->{pid}', but it is not. **" + unless kill(0, $data->{pid}); + + return $pfile unless @bad; + + my $break = ('=' x 120) . "\n"; + my $msg = join "\n" => $break, @bad, <<" EOT", $break; + +Errors like this usually indicate that the persistent runner has gone away. +Maybe the system was shut down improperly, or maybe the process was killed too +quickly to clean up after itself. + +Here is the information indicated by the persistence file: + Runner PID: $data->{pid} + Runner Vers: $data->{version} + Runner user: $data->{user} + Runner host: $data->{hostname} + Working dir: $data->{dir} + +If the persistent runner is truly gone you should delete the following file to +continue: + +$pfile + EOT + + $SEEN_ERROR = 1; + die $msg unless $params{no_fatal}; + warn $msg unless $params{no_warn}; + return $pfile; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Util - General utilities for yath that do not fit anywhere else. + +=head1 DESCRIPTION + +This package exports several tools used throughout yath that did not fit into +any other package. + +=head1 SYNOPSIS + + use App::Yath::Util qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath + }; + +=head1 EXPORTS + +Note that nothing is exported by default, you must request each function to +import. + +=over 4 + +=item $path_to_pfile = find_pfile($settings, %params) + +The first argument must be an instance of L<Test2::Harness::Settings>. + +Currently the only supported param is C<vivify>, when set to true the pfile +will be created if one does not already exist. + +The pfile is a file that tells yath that a persistent runner is active, and how +to communicate with it. + +=item $path_to_file = find_in_updir($file_name) + +Look for C<$file_name> in the current directory or any parent directory. + +=item $bool = is_generated_test_pl($path_to_test_file) + +Check if the specified test file was generated by the C<yath init> command. + +=item fit_to_width($width, $join, $text) + +This will split the C<$text> on space, and then recombine it using C<$join> +inserting newlines as necessary in an attempt to fit the text into C<$width> +horizontal characters. If any words are larger than C<$width> they will not be +split and text-wrapping may occur if used for terminal display. + +=item $stdout = isolate_stdout() + +This will close STDOUT and reopen it to point at STDERR. The result of this is +that any print statement that does not specify a fielhandle will print to +STDERR instead of STDOUT, in addition any print directly to STDOUT will instead +go to STDERR. A filehandle to the real STDOUT is returned for you to use when +you actually want to write to STDOUT. + +This is used by some yath processes that need to print structured data to +STDOUT without letting any third part modules they may load write to the real +STDOUT. + +=item $path_to_script = find_yath() + +This will attempt to find the C<yath> command line script. When possible this +will return the path that was used to launch yath. If yath was not run to start +the process it will search the paths specified in the L<Config> module. This +will throw an exception if the script cannot be found. + +Note: The result is cached so that subsequent calls will return the same path +even if something installs a new yath script in another location that would +otherwise be found first. This guarentees that a single process will not switch +scripts. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib/Test2/Formatter/QVF.pm b/bad/Test2/Formatter/QVF.pm similarity index 100% rename from lib/Test2/Formatter/QVF.pm rename to bad/Test2/Formatter/QVF.pm diff --git a/bad/Test2/Formatter/Stream.pm b/bad/Test2/Formatter/Stream.pm new file mode 100644 index 000000000..6e0f7aefd --- /dev/null +++ b/bad/Test2/Formatter/Stream.pm @@ -0,0 +1,481 @@ +package Test2::Formatter::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Time::HiRes qw/time/; +use IO::Handle; +use File::Spec(); +use List::Util qw/first/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/JSON JSON_IS_XS/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; + +use Test2::Util qw/get_tid ipc_separator/; + +use parent qw/Test2::Formatter/; +use Test2::Util::HashBase qw/-io _encoding _no_header _no_numbers _no_diag -stream_id -tb -tb_handles -dir -_pid -_tid -_fh <job_id -ugids/; + +BEGIN { + my $J = JSON->new; + $J->indent(0); + $J->convert_blessed(1); + $J->allow_blessed(1); + $J->utf8(1); + + require constant; + constant->import(ENCODER => $J); + + if (JSON_IS_XS) { + require JSON::PP; + my $JPP = JSON::PP->new; + $JPP->indent(0); + $JPP->convert_blessed(1); + $JPP->allow_blessed(1); + $JPP->utf8(1); + + constant->import(ENCODER_PP => $JPP); + } +} + +my ($ROOT_TID, $ROOT_PID, $ROOT_DIR, $ROOT_JOB_ID, $ROOT_UGIDS); +sub import { + my $class = shift; + my %params = @_; + + confess "$class no longer accept the 'file' argument, it now takes a 'dir' argument" + if exists $params{file}; + + $class->SUPER::import(); + + $ROOT_PID = $$; + $ROOT_TID = get_tid(); + $ROOT_DIR = $params{dir} if $params{dir}; + $ROOT_JOB_ID = $params{job_id} if $params{job_id}; + $ROOT_UGIDS = [$<, $>, $(, $)]; + + if ($ROOT_DIR && ! -d $ROOT_DIR) { + mkdir($ROOT_DIR) or die "Could not make root dir: $!"; + } +} + +sub hide_buffered { 0 } + +sub fh { + my $self = shift; + + my $dir = $self->{+DIR} or return undef; + + my $pid = $self->{+_PID}; + my $tid = $self->{+_TID}; + + if ($pid && $pid != $$) { + delete $self->{+_PID}; + delete $self->{+_FH}; + } + + if ($tid && $tid != get_tid()) { + delete $self->{+_TID}; + delete $self->{+_FH}; + } + + return $self->{+_FH} if $self->{+_FH}; + + $self->{+STREAM_ID} = 1; + + $pid = $self->{+_PID} = $$; + $tid = $self->{+_TID} = get_tid(); + + my $file = File::Spec->catfile($dir, join(ipc_separator() => 'events', $pid, $tid) . ".jsonl"); + + my @now = ($<, $>, $(, $)); + local ($<, $>, $(, $)) = @{$self->{+UGIDS}} if $self->{+UGIDS} && first { $self->{+UGIDS}->[$_] ne $now[$_] } 0 .. $#now; + + mkdir($dir) or die "Could not make dir '$dir': $!" unless -d $dir; + confess "File '$file' already exists!" if -f $file; + open(my $fh, '>', $file) or die "Could not open file: $file"; + $fh->autoflush(1); + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + return $self->{+_FH} = $fh; +} + +sub init { + my $self = shift; + + $self->{+STREAM_ID} = 1; + $self->{+UGIDS} //= [$<, $>, $(, $)]; + + # To create necessary directories as soon as possible + $self->fh(); + + for (@{$self->{+IO}}) { + $_->autoflush(1); + } + + STDOUT->autoflush(1); + STDERR->autoflush(1); + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stdout()->autoflush(1); + Test2::API::test2_stderr()->autoflush(1); + } + + if ($self->{check_tb}) { + require Test::Builder::Formatter; + $self->{+TB} = Test::Builder::Formatter->new(); + $self->{+TB_HANDLES} = [@{$self->{+TB}->handles}]; + } +} + +sub new_root { + my $class = shift; + my %params = @_; + + $ROOT_PID = $$ unless defined $ROOT_PID; + $ROOT_TID = get_tid() unless defined $ROOT_TID; + + confess "new_root called from child process!" + if $ROOT_PID != $$; + + confess "new_root called from child thread!" + if $ROOT_TID != get_tid(); + + require Test2::API; + my $io = $params{+IO} = [Test2::API::test2_stdout(), Test2::API::test2_stderr()]; + $_->autoflush(1) for @$io; + + confess "T2_STREAM_FILE is no longer used, see T2_STREAM_DIR" + if exists $ENV{T2_STREAM_FILE}; + + $params{+DIR} ||= $ENV{T2_STREAM_DIR} || $ROOT_DIR; + $params{+JOB_ID} ||= $ENV{T2_STREAM_JOB_ID} || $ROOT_JOB_ID || 1; + + # DO NOT REOPEN THEM! + delete $ENV{T2_FORMATTER} if $ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} eq 'Stream'; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_JOB_ID}; + $ROOT_DIR = undef; + + $params{check_tb} = 1 if $INC{'Test/Builder.pm'}; + + $params{+UGIDS} = $ROOT_UGIDS if $ROOT_UGIDS; + + return $class->new(%params); +} + +sub record { + my $self = shift; + my ($facets, $num) = @_; + + my $stamp = time; + my $times = [times]; + + my @sync = @{$self->{+IO}}; + my $leader = 0; + + my $fh = $self->fh; + unless($fh) { + $leader = 1; + $fh = shift @sync; + } + + if ($facets->{control}->{halt}) { + my $reason = $facets->{control}->{details} || ""; + + if ($leader) { + print $fh "\nBail out! $reason\n"; + } + else { + open(my $bh, '>', File::Spec->catfile($self->{+DIR}, 'bail')) or die "Could not create bail file: $!"; + print $bh $reason; + close($bh); + } + } + + my $tid = get_tid(); + my $id = $self->{+STREAM_ID}++; + + my $json; + { + no warnings 'once'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + my $event_id = $facets->{about}->{uuid} ||= gen_uuid(); + + if (JSON_IS_XS) { + for my $encoder (ENCODER, ENCODER_PP) { + local $@; + my $ok = eval { + $json = $encoder->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + 1; + }; + my $err = $@; + last if $ok; + + # Intercept bug in JSON::XS so we can fall back to JSON::PP + next if $encoder eq ENCODER && $err =~ m/Modification of a read-only value attempted/; + + # Different error, time to die. + die $err; + } + } + else { + $json = ENCODER->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + } + } + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $job_id = $self->{+JOB_ID}; + + print $fh $leader ? ("T2-HARNESS-$job_id-EVENT: ", $json, "\n") : ($json, "\n"); + + print $_ "T2-HARNESS-$job_id-ESYNC: ", join(ipc_separator() => $$, $tid, $id) . "\n" for @sync; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + $self->record({control => {encoding => $enc}}); + $self->_set_encoding($enc); + $self->{+TB}->encoding($enc) if $self->{+TB}; + } + + return $self->{+_ENCODING}; +} + +sub _set_encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + apply_encoding(\*STDOUT, $enc); + apply_encoding(\*STDERR, $enc); + + my $job_id = $self->{+JOB_ID}; + for my $fh (@{$self->{+IO}}) { + print $fh "T2-HARNESS-$job_id-ENCODING: $enc\n"; + apply_encoding($fh, $enc); + } + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub { }; +} + +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + $self->_set_encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + # Hide these if we must, but do not remove them for good. + local $f->{info} if $self->{+_NO_DIAG}; + local $f->{plan} if $self->{+_NO_HEADER}; + + my $tb_only = 0; + if ($self->{+TB}) { + $tb_only ||= $self->{+TB_HANDLES}->[0] != $self->{+TB}->{handles}->[0]; + $tb_only ||= $self->{+TB_HANDLES}->[1] != $self->{+TB}->{handles}->[1]; + + my $todo_match = $self->{+TB_HANDLES}->[0] == $self->{+TB}->{handles}->[2] + || $self->{+TB_HANDLES}->[1] == $self->{+TB}->{handles}->[2]; + + $tb_only ||= !$todo_match; + + if ($tb_only) { + my $buffered = hub_truth($f)->{buffered}; + $self->{+TB}->write($e, $num, $f) if $self->{+TB} && !$buffered; + return; + } + } + + $self->record($f, $num); +} + +sub no_header { $_[0]->{+_NO_HEADER} } +sub no_diag { $_[0]->{+_NO_DIAG} } +sub no_numbers { $_[0]->{+_NO_NUMBERS} } + +sub handles { + my $self = shift; + + return $self->{+TB}->handles if $self->{+TB}; + return; +} + +sub set_no_header { + my $self = shift; + ($self->{+_NO_HEADER}) = @_; + $self->{+TB}->set_no_header(@_) if $self->{+TB}; + $self->{+_NO_HEADER}; +} + +sub set_no_diag { + my $self = shift; + ($self->{+_NO_DIAG}) = @_; + $self->{+TB}->set_no_diag(@_) if $self->{+TB}; + $self->{+_NO_DIAG}; +} + +sub set_no_numbers { + my $self = shift; + ($self->{+_NO_NUMBERS}) = @_; + $self->{+TB}->set_no_numbers(@_) if $self->{+TB}; + $self->{+_NO_NUMBERS}; +} + +sub set_handles { + my $self = shift; + return $self->{+TB}->set_handles(@_) if $self->{+TB}; + return; +} + +sub terminate { + my $self = shift; + return $self->SUPER::terminate(@_) unless $self->{+TB}; + return $self->{+TB}->terminate(@_); +} + +sub finalize { + my $self = shift; + return $self->SUPER::finalize(@_) unless $self->{+TB}; + return $self->{+TB}->finalize(@_); +} + +sub DESTROY {} + +our $AUTOLOAD; + +sub AUTOLOAD { + my $this = shift; + + my $meth = $AUTOLOAD; + $meth =~ s/^.*:://g; + + my $type = ref($this); + + return $this->{+TB}->$meth(@_) + if $type && $this->{+TB} && $this->{+TB}->can($meth); + + $type ||= $this; + croak qq{Can't locate object method "$meth" via package "$type"}; +} + +sub isa { + my $in = shift; + return $in->SUPER::isa(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::isa(@_) || $in->{+TB}->isa(@_); +} + +sub can { + my $in = shift; + return $in->SUPER::can(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::can(@_) || $in->{+TB}->can(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Stream - Test2 Formatter that directly writes events. + +=head1 DESCRIPTION + +This formatter writes all test2 events to event files (one per process/thread) +instead of writing them to STDERR/STDOUT. It will output synchronization +messages to STDERR/STDOUT every time an event is written. From this data the +test output can be properly reconstructed in order with STDERR/STDOUT and +events mostly synced so that they appear in the correct order. + +This formatter is not usually useful to humans. This formatter is used by +L<Test2::Harness> when possible to prevent the loss of data that normally +occurs when TAP is used. + +=head1 SYNOPSIS + +If you really want your test to output this: + + use Test2::Formatter::Stream; + use Test2::V0; + ... + +Otherwise just use L<App::Yath> without the C<--no-stream> argument and this +formatter will be used when possible. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Formatter/Test2.pm b/bad/Test2/Formatter/Test2.pm new file mode 100644 index 000000000..c2d44fa85 --- /dev/null +++ b/bad/Test2/Formatter/Test2.pm @@ -0,0 +1,804 @@ +package Test2::Formatter::Test2; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Term qw/term_size/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; +use Test2::Util qw/IS_WIN32 clone_io/; +use Time::HiRes qw/time/; +use IO::Handle; + +use File::Spec(); +use Test2::Formatter::Test2::Composer; + +use parent 'Test2::Formatter'; + +sub import { + my $class = shift; + return if $ENV{HARNESS_ACTIVE}; + $class->SUPER::import; +} + +use Test2::Util::HashBase qw{ + -composer + -last_depth + -_buffered + <job_io + +io + <enc_io + -_encoding + -show_buffer + -color + -progress + -tty + -no_wrap + -verbose + -job_length + -ecount + -job_colors + -active_files + -_active_disp + -_file_stats + -job_names + -is_persistent + -interactive +}; + +sub TAG_WIDTH() { 8 } + +sub hide_buffered() { 0 } + +sub DEFAULT_TAG_COLOR() { + return ( + 'DEBUG' => Term::ANSIColor::color('red'), + 'DIAG' => Term::ANSIColor::color('yellow'), + 'ERROR' => Term::ANSIColor::color('red'), + 'FATAL' => Term::ANSIColor::color('bold red'), + 'FAIL' => Term::ANSIColor::color('red'), + 'HALT' => Term::ANSIColor::color('bold red'), + 'PASS' => Term::ANSIColor::color('green'), + '! PASS !' => Term::ANSIColor::color('cyan'), + 'TODO' => Term::ANSIColor::color('cyan'), + 'NO PLAN' => Term::ANSIColor::color('yellow'), + 'SKIP' => Term::ANSIColor::color('bold cyan'), + 'SKIP ALL' => Term::ANSIColor::color('bold white on_blue'), + 'STDERR' => Term::ANSIColor::color('yellow'), + 'RUN INFO' => Term::ANSIColor::color('bold bright_blue'), + 'JOB INFO' => Term::ANSIColor::color('bold bright_blue'), + 'LAUNCH' => Term::ANSIColor::color('bold bright_white'), + 'RETRY' => Term::ANSIColor::color('bold bright_white'), + 'PASSED' => Term::ANSIColor::color('bold bright_green'), + 'TO RETRY' => Term::ANSIColor::color('bold bright_yellow'), + 'FAILED' => Term::ANSIColor::color('bold bright_red'), + 'REASON' => Term::ANSIColor::color('magenta'), + 'TIMEOUT' => Term::ANSIColor::color('magenta'), + 'TIME' => Term::ANSIColor::color('blue'), + 'MEMORY' => Term::ANSIColor::color('blue'), + ); +} + +sub DEFAULT_FACET_COLOR() { + return ( + time => Term::ANSIColor::color('blue'), + memory => Term::ANSIColor::color('blue'), + about => Term::ANSIColor::color('magenta'), + amnesty => Term::ANSIColor::color('cyan'), + assert => Term::ANSIColor::color('bold bright_white'), + control => Term::ANSIColor::color('bold red'), + error => Term::ANSIColor::color('yellow'), + info => Term::ANSIColor::color('yellow'), + meta => Term::ANSIColor::color('magenta'), + parent => Term::ANSIColor::color('magenta'), + trace => Term::ANSIColor::color('bold red'), + ); +} + +# These colors all look decent enough to use, ordered to avoid putting similar ones together +use constant DEFAULT_JOB_COLOR_NAMES => ( + 'bold green on_blue', + 'bold blue on_white', + 'bold black on_cyan', + 'bold green on_bright_black', + 'bold dark blue on_white', + 'bold black on_green', + 'bold cyan on_blue', + 'bold black on_white', + 'bold white on_cyan', + 'bold cyan on_bright_black', + 'bold white on_green', + 'bold bright_black on_white', + 'bold white on_blue', + 'bold bright_cyan on_green', + 'bold blue on_cyan', + 'bold white on_bright_black', + 'bold bright_black on_green', + 'bold bright_green on_blue', + 'bold bright_blue on_white', + 'bold bright_white on_bright_black', + 'bold yellow on_blue', + 'bold bright_black on_cyan', + 'bold bright_green on_bright_black', + 'bold blue on_green', + 'bold bright_cyan on_blue', + 'bold bright_blue on_cyan', + 'bold dark bright_white on_bright_black', + 'bold bright_blue on_green', + 'bold dark bright_blue on_white', + 'bold bright_white on_blue', + 'bold bright_cyan on_bright_black', + 'bold bright_white on_cyan', + 'bold bright_white on_green', + 'bold bright_yellow on_blue', + #'bold magenta on_white', + #'bold dark magenta on_white', + #'bold dark cyan on_white', + 'bold dark bright_cyan on_bright_black', + #'bold dark bright_green on_black', + #'bold dark bright_yellow on_black', +); + +sub DEFAULT_JOB_COLOR() { + return map { Term::ANSIColor::color($_) } DEFAULT_JOB_COLOR_NAMES; +} + +sub DEFAULT_COLOR() { + return ( + reset => Term::ANSIColor::color('reset'), + blob => Term::ANSIColor::color('bold bright_black on_white'), + tree => Term::ANSIColor::color('bold bright_white'), + tag_border => Term::ANSIColor::color('bold bright_white'), + ); +} + +my %FACET_TAG_BORDERS = ( + 'default' => ['[', ']'], + 'amnesty' => ['{', '}'], + 'info' => ['(', ')'], + 'error' => ['<', '>'], + 'parent' => [' ', ' '], +); + +sub init { + my $self = shift; + + $self->{+COMPOSER} ||= Test2::Formatter::Test2::Composer->new; + + $self->{+VERBOSE} = 1 unless defined $self->{+VERBOSE}; + + $self->{+JOB_LENGTH} ||= 2; + + my $io = $self->{+IO} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + + $self->{+TTY} = -t $io unless defined $self->{+TTY}; + + my $use_color = ref($self->{+COLOR}) ? 1 : delete($self->{+COLOR}); + $use_color = $self->{+TTY} unless defined $use_color; + + if ($use_color && USE_ANSI_COLOR) { + $self->{+SHOW_BUFFER} = 1 unless defined $self->{+SHOW_BUFFER}; + + if ($use_color) { + $self->{+COLOR} = { + DEFAULT_COLOR(), + TAGS => {DEFAULT_TAG_COLOR()}, + FACETS => {DEFAULT_FACET_COLOR()}, + JOBS => [DEFAULT_JOB_COLOR()], + } unless defined $self->{+COLOR}; + + $self->{+JOB_COLORS} = {free => [@{$self->{+COLOR}->{JOBS}}]}; + } + } + else { + $self->{+SHOW_BUFFER} = 0 unless defined $self->{+SHOW_BUFFER}; + } + + $self->{+ECOUNT} //= 0; + + my $reset = $use_color ? Term::ANSIColor::color('reset') : ''; + my $cyan = $use_color ? Term::ANSIColor::color('cyan') : ''; + $self->{+_ACTIVE_DISP} = ["[${cyan}INITIALIZING${reset}]", '']; + $self->{+_FILE_STATS} = { + passed => 0, + failed => 0, + running => 0, + todo => 0, + total => 0, + }; + + +} + +sub io { + my $self = shift; + my ($job_id) = @_; + return $self->{+IO} unless defined $job_id; + return $self->{+JOB_IO}->{$job_id} // $self->{+IO}; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc, $job_id) = @_; + if (defined $job_id) { + my $io; + + unless ($io = $self->{+ENC_IO}->{$enc}) { + $io = $self->{+ENC_IO}->{$enc} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + apply_encoding($io, $enc); + } + + $self->{+JOB_IO}->{$job_id} = $io; + } + else { + apply_encoding($self->{+IO}, $enc); + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + my $should_show = $self->update_active_disp($f); + + $self->{+ECOUNT}++; + + my $job_id = $f->{harness}->{job_id}; + $self->encoding($f->{control}->{encoding}, $job_id) if $f->{control}->{encoding}; + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + return if $depth && (!$self->{+SHOW_BUFFER} || !$self->{+PROGRESS}); + + my $lines; + if (!$self->{+VERBOSE}) { + if ($depth) { + $lines = []; + } + else { + $lines = $self->render_quiet($f); + } + } + elsif ($depth) { + my $tree = $self->render_tree($f, '>'); + $lines = $self->render_buffered_event($f, $tree); + } + else { + my $tree = $self->render_tree($f,); + $lines = $self->render_event($f, $tree); + } + + $should_show ||= $lines && @$lines; + unless ($should_show || $self->{+VERBOSE}) { + if (my $last = $self->{last_rendered}) { + return if time - $last < 0.2; + $self->{last_rendered} = time; + } + else { + $self->{last_rendered} = time; + } + } + + push @{$self->{+JOB_COLORS}->{free}} => delete $self->{+JOB_COLORS}->{used}->{$job_id} + if $job_id && $f->{harness_job_end}; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->io($job_id); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if (!$self->{+VERBOSE}) { + print $io $_, "\n" for @$lines; + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + } + elsif ($depth && $lines && @$lines && !$self->{+INTERACTIVE}) { + print $io $lines->[0]; + $self->{+_BUFFERED} = 1; + } + else { + print $io $_, "\n" for @$lines; + } + + delete $self->{+JOB_IO}->{$job_id} if $job_id && $f->{harness_job_end}; +} + +sub finalize { + my $self = shift; + + my $io = $self->{+IO}; + print $io "\r\e[K" if $self->{+_BUFFERED}; + + return; +} + +sub step { + my $self = shift; + + return unless $self->update_active_disp; + + my $io = $self->io(0); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status(); + $self->{+_BUFFERED} = 1; + } +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + my $should_show = 0; + + my $stats = $self->{+_FILE_STATS}; + + my $out = 0; + $out = $self->update_spinner($stats) unless $stats->{started}; + + return $out unless $f; + + if (my $task = $f->{harness_job_queued}) { + $self->{+JOB_NAMES}->{$task->{job_id}} = $task->{job_name} || $task->{job_id}; + $stats->{total}++; + $stats->{todo}++; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($job->{file})} = $job->{job_name} || $job->{job_id}; + $should_show = 1; + $stats->{running}++; + $stats->{todo}--; + $stats->{started} //= 1; + } + + if ($f->{harness_job_end}) { + my $file = $f->{harness_job_end}->{file}; + delete $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($file)}; + $should_show = 1; + $stats->{running}--; + + if ($f->{harness_job_end}->{fail}) { + $stats->{failed}++; + } + else { + $stats->{passed}++; + } + } + + return $out unless $should_show; + + my $statline = join '|' => ( + $self->_highlight($stats->{passed}, 'P', 'green'), + $self->_highlight($stats->{failed}, 'F', 'red'), + $self->_highlight($stats->{running}, 'R', 'cyan'), + $self->_highlight($stats->{todo}, 'T', 'yellow'), + ); + + $statline = "[$statline]"; + + my $active = $self->{+ACTIVE_FILES}; + + return $self->{+_ACTIVE_DISP} = [$statline, ''] unless $active && keys %$active; + + my $reset = $self->reset; + + my $str .= "("; + { + no warnings 'numeric'; + $str .= join(' ' => map { m{([^/]+)$}; "$active->{$_}:$1" } sort { ($active->{$a} || 0) <=> ($active->{$b} || 0) or $a cmp $b } keys %$active); + } + $str .= ")"; + + $self->{+_ACTIVE_DISP} = [$statline, $str]; + + return 1; +} + +sub update_spinner { + my $self = shift; + my ($stats) = @_; + + $stats->{spinner} //= '|'; + $stats->{spinner_time} //= time - 1; + $stats->{blink_time} //= time - 1; + $stats->{blink} //= ''; + + if (time - $stats->{spinner_time} > 0.1) { + $stats->{spinner_time} = time; + my $start = substr($stats->{spinner}, 0, 1); + $stats->{spinner} = '\\' if $start eq '-'; + $stats->{spinner} = '-' if $start eq '/'; + $stats->{spinner} = '/' if $start eq '|'; + $stats->{spinner} = '|' if $start eq '\\'; + } + elsif(time - $stats->{blink_time} > 0.5) { + $stats->{blink_time} = time; + $stats->{blink} = $stats->{blink} ? '' : 'bold bright_'; + } + else { + return 0; + } + + my $yellow = $self->{+COLOR} ? Term::ANSIColor::color($stats->{blink} . 'yellow') : ''; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + my $green = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_green') : ''; + my $bold = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_white') : ''; + my $reset = $self->reset; + + $self->{+_ACTIVE_DISP} = [ + join( + '' => ( + $bold => "[ ", $reset, + $green => $stats->{spinner}, $reset, + '' => " ", + $self->{+IS_PERSISTENT} + ? ( + $yellow => "Waiting for busy runner", $reset, + '' => " ", + $reset => "(see ", $reset, + $cyan => "yath status", $reset, + $reset => ")", $reset, + ) + : ($yellow => "INITIALIZING", $reset), + '' => " ", + $green => $stats->{spinner}, $reset, + $bold => " ]", $reset, + ) + ), + '', + ]; + + return 1; +} + +sub _highlight { + my $self = shift; + my ($val, $label, $color) = @_; + + return "${label}:${val}" unless $val && $self->{+COLOR}; + return sprintf('%s%s:%d%s', Term::ANSIColor::color($color), $label, $val, $self->reset); +} + + +sub colorstrip { + my $self = shift; + my ($str) = @_; + + return $str unless USE_ANSI_COLOR; + return Term::ANSIColor::colorstrip($str); +} + +sub render_status { + my $self = shift; + + my $reset = $self->reset; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + + my $str = "$self->{+_ACTIVE_DISP}->[0] Events: $self->{+ECOUNT} ${cyan}$self->{+_ACTIVE_DISP}->[1]${reset}"; + + my $max = term_size() || 80; + + if (length($str) > $max) { + my $nocolor = $self->colorstrip($str); + $str = substr($nocolor, 0, $max - 8) . " ...)$reset" if length($nocolor) > $max; + $str =~ s/\(/$cyan(/; + $str =~ s/^\[[^\]]+\]/$self->{+_ACTIVE_DISP}->[0]/; + } + + return $str; +} + +sub render_buffered_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comp = $self->{+COMPOSER}->render_one_line($f) or return; + + return unless @$comp; + return [$self->build_line($tree, @$comp)]; +} + +sub render_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comps = $self->{+COMPOSER}->render_verbose($f); + + my (@parent, @times); + + if ($f->{parent}) { + @parent = $self->render_parent($f, $tree); + + if (@$comps && $comps->[-1]->[0] eq 'times') { + my $times = pop(@$comps); + @times = $self->build_line($tree, @$times); + } + } + + my @out; + + for my $comp (@$comps) { + my $ctree = $tree; + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + push @out => (@parent, @times); + + return \@out; +} + +sub render_quiet { + my $self = shift; + my ($f, $tree) = @_; + + my @out; + + my $comps = $self->{+COMPOSER}->render_brief($f); + for my $comp (@$comps) { + my $ctree = $tree ||= $self->render_tree($f); + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + if ($f->{parent} && !$f->{amnesty}) { + push @out => $self->render_parent($f, $tree ||= $self->render_tree($f), quiet => 1); + } + + return \@out; +} + +sub reset { + my $self = shift; + return $self->{+COLOR} ? $self->{+COLOR}->{reset} : ''; +} + +sub job_color { + my $self = shift; + my ($id, $set) = @_; + return '' unless $self->{+JOB_COLORS}; + return $self->{+JOB_COLORS}->{used}->{$id} || '' unless $set; + return $self->{+JOB_COLORS}->{used}->{$id} ||= shift @{$self->{+JOB_COLORS}->{free}} || ''; +} + +sub render_tree { + my $self = shift; + my ($f, $char) = @_; + $char ||= '|'; + + my $job = ''; + if ($f->{harness} && $f->{harness}->{job_id}) { + my $id = $f->{harness}->{job_id}; + my $name = $self->{+JOB_NAMES}->{$id}; + + my ($color, $reset) = ('', ''); + if ($self->{+JOB_COLORS}) { + $color = $self->job_color($id, 'set'); + $reset = $self->reset; + } + + my $len = length($name); + if (!$self->{+JOB_LENGTH} || $len > $self->{+JOB_LENGTH}) { + $self->{+JOB_LENGTH} = $len; + } + else { + $len = $self->{+JOB_LENGTH}; + } + + $job = sprintf("%sjob %${len}s%s ", $color, $name, $reset || ''); + } + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + my @pipes = (' ', map $char, 1 .. $depth); + return join(' ' => $job, @pipes) . ' '; +} + +sub build_line { + my $self = shift; + my ($tree, $facet, $tag, $text) = @_; + + $tree ||= ''; + $tag ||= ''; + $text ||= ''; + chomp($text); + + substr($tree, -2, 1, '+') if $facet eq 'assert'; + + $tag = substr($tag, 0 - TAG_WIDTH, TAG_WIDTH) if length($tag) > TAG_WIDTH; + + my $max = $self->{+TTY} && !$self->{+NO_WRAP} ? (term_size() || 80) : undef; + my $color = $self->{+COLOR}; + my $reset = $self->reset; + my $tcolor = $color ? $color->{TAGS}->{$tag} || $color->{FACETS}->{$facet} || '' : ''; + + my ($ps, $pe) = @{$FACET_TAG_BORDERS{$facet} || $FACET_TAG_BORDERS{default}}; + + $tag = uc($tag); + my $length = length($tag); + if ($length > TAG_WIDTH) { + $tag = substr($tag, 0, TAG_WIDTH); + } + elsif($length < TAG_WIDTH) { + my $pad = (TAG_WIDTH - $length) / 2; + my $padl = $pad + (TAG_WIDTH - $length) % 2; + $tag = (' ' x $padl) . $tag . (' ' x $pad); + } + + my $start; + if ($color) { + my $border = $color->{tag_border} || ''; + $start = "${reset}${border}${ps}${reset}${tcolor}${tag}${reset}${border}${pe}${reset}"; + } + else { + $start = "${ps}${tag}${pe}"; + } + $start .= " "; + + if ($tree) { + if ($color) { + my $trcolor = $color->{tree} || ''; + $start .= $trcolor . $tree . $reset; + } + else { + $start .= $tree; + } + } + + my @lines = split /[\r\n]/, $text; + @lines = ($text) unless @lines; + + my @out; + for my $line (@lines) { + if(@lines > 1 && $max && length("$ps$tag$pe $tree$line") > $max) { + @out = (); + last; + } + + if ($color) { + push @out => "${start}${tcolor}${line}$reset"; + } + else { + push @out => "${start}${line}"; + } + } + + return @out if @out; + + return ( + "$start----- START -----", + $text, + "$start------ END ------", + ) unless $color; + + my $blob = $color->{blob} || ''; + return ( + "$start${blob}----- START -----$reset", + "${tcolor}${text}${reset}", + "$start${blob}------ END ------$reset", + ); +} + +sub render_parent { + my $self = shift; + my ($f, $tree, %params) = @_; + + my $meth = $params{quiet} ? 'render_quiet' : 'render_event'; + + my @out; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness} ||= $f->{harness}; + my $tree = $self->render_tree($sf); + push @out => @{$self->$meth($sf, $tree)}; + } + + return unless @out; + + push @out => ( + $self->build_line("$tree^", 'parent', '', ''), + ); + + return @out; +} + + +sub DESTROY { + my $self = shift; + + my $io = $self->{+IO} or return; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + print $io Term::ANSIColor::color('reset') + if USE_ANSI_COLOR; + + print $io "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2 - An alternative to TAP, used by Test2::Harness. + +=head1 DESCRIPTION + +This formatter is the primary formatter used for final result rendering when +you use Test2::Harness. This formatter is NOT designed to have its output +consumed by code/machine/harnesses. The goal of this formatter is to have +output that is easily read by humans. + +=head1 SYNOPSIS + +If you are running a test directly with perl and want to use this formatter: + + $ perl -MTest2::Formatter::Test2 path/to/test.t + +You could also use the module directly in your test, but that is not +recommended as your test would then be unable to be run via prove or other +harnesses. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Formatter/Test2/Composer.pm b/bad/Test2/Formatter/Test2/Composer.pm new file mode 100644 index 000000000..d6b642d19 --- /dev/null +++ b/bad/Test2/Formatter/Test2/Composer.pm @@ -0,0 +1,507 @@ +package Test2::Formatter::Test2::Composer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use List::Util qw/first/; + +sub new { + my $class = shift; + return bless({}, $class); +} + +sub render_one_line { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + return [$f->{render}->[0]->{facet}, uc($f->{render}->[0]->{tag}), $f->{render}->[0]->{details}] + if $f->{render} && @{$f->{render}}; + + return (($class->halt($f))[0]) if $class->{control} && defined $class->{control}->{halt}; + + for my $type (qw/assert errors plan info times about/) { + next unless $f->{$type}; + my $m = "render_$type"; + my ($out) = $class->$m($f); + return $out if defined $out; + } + + return; +} + +sub render_verbose { + my $class = shift; + my ($in, %params) = @_; + + my $f = blessed($in) ? $in->facet_data : $in; + + return [map {[$_->{facet}, uc($_->{tag}), $_->{details}]} @{$f->{render}}] + if $f->{render} && @{$f->{render}}; + + my @out; + + push @out => $class->render_control($f, %params) if $f->{control}; + push @out => $class->render_plan($f) if $f->{plan}; + + if ($f->{assert}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{pass} || $f->{assert}->{no_debug}; + push @out => $class->render_amnesty($f) if $f->{amnesty} && @{$f->{amnesty}}; + } + + push @out => $class->render_info($f) if $f->{info}; + push @out => $class->render_errors($f) if $f->{errors}; + + push @out => $class->render_about($f) + if $f->{about} && !(@out || first { $f->{$_} } qw/stop plan info nest assert/); + + return \@out; +} + +sub render_super_verbose { + my $class = shift; + my ($in) = @_; + + my $out = $class->render_verbose($in, super_verbose => 1); + + my $f = blessed($in) ? $in->facet_data : $in; + + push @$out => $class->render_launch($f) if $f->{harness_job_launch}; + push @$out => $class->render_start($f) if $f->{harness_job_start}; + push @$out => $class->render_exit($f) if $f->{harness_job_exit}; + push @$out => $class->render_end($f) if $f->{harness_job_end}; + + unless (@$out) { + my ($name, $fallback); + for my $k (sort keys %$f) { + my $v = $f->{$k}; + + # Fallback should be longest harness* facet name + $fallback = $k if $k =~ m/harness/ && (!$fallback || length($fallback) < length($k)); + + my $list = ref($v) eq 'ARRAY' ? $v : [$v]; + for my $i (@$list) { + next unless ref($i); + last if $name = $i->{details}; + } + } + + $name //= $fallback // join ', ' => sort keys %$f; + + push @$out => ['harness', 'HARNESS', $name]; + } + + return $out; +} + +sub render_launch { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', 'Job Launched at ' . $f->{harness_job_launch}->{stamp}]; +} + +sub render_start { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_start}->{details}]; +} + +sub render_exit { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_exit}->{details}]; +} + +sub render_end { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', "Job completed at " . $f->{harness_job_end}->{stamp}]; +} + +sub render_control { + my $class = shift; + my ($f, %params) = @_; + + my @out; + + push @out => ['control', 'HALT', $f->{control}->{details}] + if defined $f->{control}->{halt}; + + return @out unless $params{super_verbose}; + + push @out => ['control', 'ENCODING', $f->{control}->{encoding}] + if $f->{control}->{encoding}; + + return @out if @out; + + return ['control', 'CONTROL', $f->{control}->{details}] + if defined $f->{control}->{details}; + + return; +} + +my %SHOW_BRIEF_TAGS = ( + 'CRITICAL' => 1, + 'DEBUG' => 1, + 'DIAG' => 1, + 'ERROR' => 1, + 'FAIL' => 1, + 'FAILED' => 1, + 'FATAL' => 1, + 'HALT' => 1, + 'PASSED' => 1, + 'REASON' => 1, + 'STDERR' => 1, + 'TIMEOUT' => 1, + 'WARN' => 1, + 'WARNING' => 1, + 'KILL' => 1, + 'SKIPPED' => 1, +); + +my %SHOW_BRIEF_FACETS = ( + control => 1, + error => 1, + trace => 1, +); + +sub render_brief { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + if ($f->{render} && @{$f->{render}}) { + my @show = grep { $SHOW_BRIEF_TAGS{uc($_->{tag})} || $SHOW_BRIEF_FACETS{lc($_->{facet})} } @{$f->{render}}; + return [map { [$_->{facet}, uc($_->{tag}), $_->{details}] } @show]; + } + + my @out; + + push @out => $class->render_control($f) if $f->{control}; + + if ($f->{assert} && !$f->{assert}->{pass} && !$f->{amnesty}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{no_debug}; + } + + if ($f->{info}) { + my $if = {%$f, info => [grep { $_->{debug} || $_->{important} } @{$f->{info}}]}; + push @out => $class->render_info($if) if @{$if->{info}}; + } + + push @out => $class->render_errors($f) if $f->{errors}; + + return \@out; +} + +sub render_plan { + my $class = shift; + my ($f) = @_; + + my $plan = $f->{plan}; + return ['plan', 'NO PLAN', $f->{plan}->{details}] if $plan->{none}; + + if ($plan->{skip}) { + return ['plan', 'SKIP ALL', $f->{plan}->{details}] + if $f->{plan}->{details}; + + return ['plan', 'SKIP ALL', "No reason given"]; + } + + return ['plan', 'PLAN', "Expected assertions: $f->{plan}->{count}"]; +} + +sub render_assert { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details} || '<UNNAMED ASSERTION>'; + + return ['assert', '! PASS !', $name] + if $f->{amnesty} && @{$f->{amnesty}}; + + return ['assert', 'PASS', $name] + if $f->{assert}->{pass}; + + return ['assert', 'FAIL', $name] +} + +sub render_amnesty { + my $class = shift; + my ($f) = @_; + + my %seen; + return map { + $seen{join '' => @{$_}{qw/tag details/}}++ + ? () + : ['amnesty', $_->{tag}, $_->{details}] + } @{$f->{amnesty}}; +} + +sub render_debug { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug; + if ($trace) { + $debug = $trace->{details}; + if(!$debug && $trace->{frame}) { + my $frame = $trace->{frame}; + $debug = "$frame->[1] line $frame->[2]"; + } + } + + $debug ||= "[No trace info available]"; + + chomp($debug); + + return ['trace', 'DEBUG', $debug]; +} + +sub render_info { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details} // ''; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + ['info', $_->{tag}, $details, $_->{table} || ()] + } @{$f->{info}}; +} + +sub render_about { + my $class = shift; + my ($f) = @_; + + return if $f->{about}->{no_display}; + return unless $f->{about} && $f->{about}->{details}; + + my $type; + if ($f->{about}->{package}) { + my $type = $f->{about}->{package}; + $type =~ s/^.*:://; + } + $type //= 'ABOUT'; + + return ['about', $type, $f->{about}->{details}]; +} + +sub render_errors { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + my $tag = $_->{tag} || ($_->{fail} ? 'FATAL' : 'ERROR'); + + ['error', $tag, $details] + } @{$f->{errors}}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2::Composer - Compose output components from event facets + +=head1 DESCRIPTION + +This is used by L<Test2::Formatter::Test2> to turn events into output +components. This logic lives here instead of in the formatter because it is +also used by L<Test2::Harness::UI>. Other tools may also find this conversion +useful. + +=head1 SYNOPSIS + + use Test2::Formatter::Test2::Composer; + + # Note, all methods are class methods, this is just here for convenience. + my $comp = Test2::Formatter::Test2::Composer->new(); + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + ... + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=head1 METHODS + +All methods are class methods, but they also work just fine on a blessed +instance. There is no benefit to a blessed instance, but you can create one for +convenience if it makes you more comfortable. + +=over 4 + +=item $inst = $class->new() + +Create a blessed instance. This is here for convenience only. All methods are +class methods. + +=item $arrayref = $class->render_one_line($event) + +=item $arrayref = $class->render_one_line(\%facet_data) + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + +This will return a single line of output from the event, even if the event +would normally return multiple lines. + +In order of priority: + +=over 4 + +=item Custom 'render' facet + +=item Control 'halt' facet (bail-out) + +=item Assertion (pass/fail) + +=item Error message + +=item Plan + +=item Info (note/diag) + +=item Timing data + +=item About + +=back + +=item @lines = $class->render_verbose($event, %control_params) + +=item @lines = $class->render_verbose(\%facet_data, %control_params) + +This will verbosely render any event. The C<%control_params> are passed +directly to C<render_control()> and are not used for anything else. + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=item @lines = $class->render_super_verbose($event) + +=item @lines = $class->render_super_verbose(\%facet_data) + +This is even more verbose than C<render_verbose()> because it produces output +lines even for facets that should normally not be seen, things that would +usually be considered noise. + +This is mainly useful for tools that allow deep inspection of log files. + +=back + +=head2 FACET RENDERERS + +With exception of C<render_control()> these are all the same. These all take +C<\%facet_data> as their only argument, and return a list of line-arrayrefs +C<[$facet, $tag, $text_for_humans]>. + +=over 4 + +=item @lines = $class->render_control(\%facet_data, super_verbose => $bool) + +This specific one is special in that it can take an extra argument. This +argument is used to toggle between super_verbose and regular verbosity. No +other facet renderer needs this toggle. If omitted it defaults to not being +super verbose. + +=item @lines = $class->render_launch(\%facet_data) + +=item @lines = $class->render_start(\%facet_data) + +=item @lines = $class->render_exit(\%facet_data) + +=item @lines = $class->render_end(\%facet_data) + +=item @lines = $class->render_brief(\%facet_data) + +=item @lines = $class->render_plan(\%facet_data) + +=item @lines = $class->render_assert(\%facet_data) + +=item @lines = $class->render_amnesty(\%facet_data) + +=item @lines = $class->render_debug(\%facet_data) + +=item @lines = $class->render_info(\%facet_data) + +=item @lines = $class->render_about(\%facet_data) + +=item @lines = $class->render_errors(\%facet_data) + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness.pm b/bad/Test2/Harness.pm new file mode 100644 index 000000000..de5d06345 --- /dev/null +++ b/bad/Test2/Harness.pm @@ -0,0 +1,60 @@ +package Test2::Harness; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness - A new and improved test harness with better L<Test2> +integration. + +=head1 DESCRIPTION + +Test2::Harness is the backend code that handles running/processing the tests. +In general a user will not use it directly, instead you should probably be +looking at L<App::Yath> which is the UI layer built around Test2::Harness. + +=head1 SEE ALSO + +The primary documentation can be found in L<App::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Auditor.pm b/bad/Test2/Harness/Auditor.pm new file mode 100644 index 000000000..c594246e5 --- /dev/null +++ b/bad/Test2/Harness/Auditor.pm @@ -0,0 +1,176 @@ +package Test2::Harness::Auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Time::HiRes qw/time/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use Test2::Harness::Event; +use Test2::Harness::Auditor::Watcher; + +use Test2::Harness::Util::HashBase qw{ + <action + <run_id + + +broken + + <watchers + <queued +}; + +sub init { + my $self = shift; + + $self->{+WATCHERS} //= {}; +} + +sub process { + my $self = shift; + + while (my $line = <STDIN>) { + my $data = decode_json($line); + last unless defined $data; + my $e = Test2::Harness::Event->new($data); + + # If process_event does not return anything we need to record just this + # event. If it does return then we want to record what it returns. + if (my @events = $self->process_event($e)) { + $self->{+ACTION}->($_) for @events; + } + else { + $self->{+ACTION}->($e); + } + } +} + +sub process_event { + my $self = shift; + my ($e) = @_; + + my $job_id = $e->job_id; + my $job_try = $e->job_try // 0; + + # Do nothing for non-job events + return $e unless $job_id; + + my $f = $e->facet_data; + + if (my $task = $f->{harness_job_queued}) { + $self->{+WATCHERS}->{$job_id} //= []; + $self->{+QUEUED}->{$job_id} //= $task; + return $e; + } + + my $tries = $self->{+WATCHERS}->{$job_id} or return $self->broken($e, "Never saw queue entry"); + + if (my $job = $f->{harness_job}) { + $tries->[$job_try] = Test2::Harness::Auditor::Watcher->new(job => $job, try => $job_try); + } + + my $watcher = $tries->[$job_try] or return $self->broken($e, "never saw harness_job facet"); + + return $watcher->process($e); +} + +sub broken { + my $self = shift; + my ($e, $message) = @_; + + $self->{+BROKEN}->{$e->job_id}++; + + push @{$e->facet_data->{errors} //= []} => {details => $message, fail => 1}; + + return $e; +} + +sub finish { + my $self = shift; + + my $final_data = {pass => 1}; + + while (my ($job_id, $watchers) = each %{$self->{+WATCHERS}}) { + my $file = File::Spec->abs2rel($self->{+QUEUED}->{$job_id}->{file}); + + if (@$watchers) { + push @{$final_data->{failed}} => [$job_id, $file, $watchers->[-1]->failed_subtest_tree] if $watchers->[-1]->fail; + push @{$final_data->{retried}} => [$job_id, scalar(@$watchers), $file, $watchers->[-1]->pass ? 'YES' : 'NO'] if @$watchers > 1; + + if (my $halt = $watchers->[-1]->halt) { + push @{$final_data->{halted}} => [$job_id, $file, $halt]; + } + } + else { + push @{$final_data->{unseen}} => [$job_id, $self->{+QUEUED}->{$job_id}->{file}]; + } + } + + $final_data->{pass} = 0 if $final_data->{failed} or $final_data->{unseen}; + + my $e = Test2::Harness::Event->new( + job_id => 0, + stamp => time, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => {harness_final => $final_data}, + ); + + $self->{+ACTION}->($e); + $self->{+ACTION}->(undef); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor - Auditor that validates test results by processing an +event stream. + +=head1 DESCRIPTION + +The auditor is responsible for taking a stream of events and determining what +is passing or failing. An L<Test2::Harness::Auditor::Watcher> instance is +created for every job_id seen, and events for each job are passed to the proper +watcher for state management. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Auditor/TimeTracker.pm b/bad/Test2/Harness/Auditor/TimeTracker.pm new file mode 100644 index 000000000..7da18c0fa --- /dev/null +++ b/bad/Test2/Harness/Auditor/TimeTracker.pm @@ -0,0 +1,370 @@ +package Test2::Harness::Auditor::TimeTracker; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/hub_truth/; +use Test2::Util::Times qw/render_duration/; + +use Test2::Harness::Util::HashBase qw{ + -start -start_id + -stop -stop_id + -first -first_id + -last -last_id + -complete_id + + -_source + -_totals +}; + +sub process { + my $self = shift; + my ($event, $f, $assertion_count) = @_; + + # Invalidate cache + delete $self->{+_TOTALS}; + delete $self->{+_SOURCE}; + + my $stamp = $event->{stamp} or return; + my $id = $event->{event_id} // 'N/A'; + + $f //= $event->{facet_data}; + + if ($f->{harness_job_exit}) { + $self->{+STOP} = $stamp; + $self->{+STOP_ID} = $id; + } + + return if $self->{+COMPLETE_ID}; + + if ($f->{harness_job_start}) { + $self->{+START} = $stamp; + $self->{+START_ID} = $id; + } + + # These events absolutely end the events phase, and do not count as part of + # it. + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{harness_job_exit}; + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{control} && $f->{control}->{phase} && $f->{control}->{phase} eq 'END'; + + return if $self->{+COMPLETE_ID}; + + # Plan still counts as 'event' phase, so do not return if we are setting this now + $self->{+COMPLETE_ID} //= $event->{event_id} if $assertion_count && $f->{plan} && !$f->{plan}->{none}; + + return unless $f->{trace}; # Events with traces are "event" phase. + + # Always replace the last, if we got this far. + $self->{+LAST} = $stamp; + $self->{+LAST_ID} = $id; + + # Only set the first one once + return if $self->{+FIRST}; + $self->{+FIRST} = $stamp; + $self->{+FIRST_ID} = $id; + + return; +} + +sub useful { + my $self = shift; + + my @got = grep { defined $self->{$_} } START, FIRST, LAST, STOP; + return @got > 1; +} + +my @TOTAL_FIELDS = qw/startup events cleanup total/; +my %TOTAL_SOURCES = ( + startup => [FIRST, START], + events => [LAST, FIRST], + cleanup => [STOP, LAST], + total => [STOP, START] +); +my %TOTAL_DESC = ( + startup => "Time from launch to first test event.", + events => "Time spent generating test events.", + cleanup => "Time from last test event to test exit.", + total => "Total time", +); + +sub totals { + my $self = shift; + + return $self->{+_TOTALS} if $self->{+_TOTALS}; + + my $out = {}; + + for my $field (@TOTAL_FIELDS) { + my $sources = $TOTAL_SOURCES{$field} or die "Invalid field: $field"; + my @vals = @{$self}{@$sources}; + next unless defined($vals[0]) && defined($vals[1]); + + my $delta = $vals[0] - $vals[1]; + $out->{$field} = $delta; + $out->{"h_$field"} = render_duration($delta); + } + + return $self->{+_TOTALS} = $out; +} + +sub source { + my $self = shift; + + return $self->{+_SOURCE} if $self->{+_SOURCE}; + + my @fields = ( + START, START_ID, + STOP, STOP_ID, + FIRST, FIRST_ID, + LAST, LAST_ID, + COMPLETE_ID, + ); + + my %out; + @out{@fields} = @{$self}{@fields}; + + return $self->{+_SOURCE} = \%out; +} + +sub data_dump { + my $self = shift; + + return { + totals => $self->totals, + source => $self->source, + }; +} + +sub summary { + my $self = shift; + my $totals = $self->totals; + + my $summary = ""; + for my $field (@TOTAL_FIELDS) { + my $hval = $totals->{"h_$field"} // next; + my $title = ucfirst($field); + + $summary .= " | " if $summary; + $summary .= "$title: $hval"; + } + + return $summary; +} + +sub table { + my $self = shift; + my $totals = $self->totals; + + my $table = { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [], + }; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + my $title = ucfirst($field); + + push @{$table->{rows}} => [$title, $hval, $val, $TOTAL_DESC{$field}]; + } + + return $table; +} + +sub job_fields { + my $self = shift; + my $totals = $self->totals; + + my @out; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + + my $data = {}; + my $sources = $TOTAL_SOURCES{$field}; + for my $source (@$sources) { + $data->{$source} = { + stamp => $self->{$source}, + event_id => $self->{"${source}_id"}, + }; + } + + push @out => {name => "time_$field", details => $hval, raw => $val, data => $data}; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor::TimeTracker - Module that tracks timing data while an +event stream is processed. + +=head1 DESCRIPTION + +The timetracker module tracks timing data of an event stream. All events for a +given job should be run through a timetracker, which can then give data on how +long the test took in each of several stages. + +=over 4 + +=item startup - Time from launch to first test event. + +=item events - Time spent generating test events. + +=item cleanup - Time from last test event to test exit. + +=item total - Total time. + +=back + +=head1 SYNOPSIS + + use Test2::Harness::Auditor::TimeTracker; + + my $tracker = Test2::Harness::Auditor::TimeTracker->new(); + + my $assert_count = 0; + for my $event (@events) { + my $facet_data = $events->facet_data; + $assert_count++ if $facet_data->{assert}; + $tracker->process($event, $facet_data, $assert_count); + } + + print $tracker->summary; + # Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +=head1 METHODS + +=over 4 + +=item $tracker->process($event, $facet_data, $assert_count) + +=item $tracker->process($event, undef, $assert_count) + +TimeTracker builds its state from multiple events, each event should be +processed by this method. + +The second argument is optional, if no facet_data is provided it will pull the +facet_data from the event itself. This is mainly a micro-optimization to avoid +calling the C<facet_data()> method on the event multiple times if you have +already called it. + +=item $bool = $tracker->useful() + +Returns true if there is any useful data to display. + +=item $totals = $tracker->totals() + +Returns the totals like this: + + { + # Raw numbers + startup => ..., + events => ..., + cleanup => ..., + total => ..., + + # Human friendly versions + h_startup => ..., + h_events => ..., + h_cleanup => ..., + h_total => ..., + } + +=item $source = $tracker->source() + +This method returns the data from which the totals are derived. + + { + start => ..., # timestamp of the job starting + stop => ..., # timestamp of the job ending + first => ..., # timestamp of the first non-harness event + last => ..., # timestamp of the last non-harness event + + # These are event_id's of the events that provided the above stamps. + start_id => ..., + stop_id => ..., + first_id => ..., + last_id => ..., + complete_id => ..., + } + +=item $data = $tracker->data_dump + +This dumps the totals and source data: + + { + totals => $tracker->totals, + source => $tracker->source, + } + +=item $string = $tracker->summary + +This produces a summary string of the totals data: + + Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +Fields that have no data will be ommited from the string. + +=item $table = $tracker->table + +Returns this structure that is good for use in L<Term::Table>. + + { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [ + ['startup', $human_readible, $raw, "Time from launch to first test event."], + ['events', $human_radible, $raw, 'Time spent generating test events.'], + ['cleanup', $human_radible, $raw, 'Time from last test event to test exit.'], + ['total', $human_radible, $raw, 'Total time.'], + ], + } + +=item @items = $tracker->job_fields() + +This is used to obtain extra data to attach to the job completion event. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Auditor/Watcher.pm b/bad/Test2/Harness/Auditor/Watcher.pm new file mode 100644 index 000000000..7b730a740 --- /dev/null +++ b/bad/Test2/Harness/Auditor/Watcher.pm @@ -0,0 +1,488 @@ +package Test2::Harness::Auditor::Watcher; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use List::Util qw/first max/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util qw/hub_truth parse_exit/; + +use Test2::Harness::Auditor::TimeTracker; + +use Test2::Harness::Util::HashBase qw{ + -job + -try + + -assertion_count + -exit + -plan + -_errors + -_failures + -_sub_failures + -_plans + -_info + -_sub_info + -_subtest_id + -nested + -subtests + -numbers + -times + -halt + -failed_subtest_tree +}; + +sub init { + my $self = shift; + + croak "'job' is a required attribute" + unless $self->{+JOB}; + + croak "'try' is a required attribute" + unless defined $self->{+TRY}; + + $self->{+_FAILURES} = 0; + $self->{+_ERRORS} = 0; + $self->{+ASSERTION_COUNT} = 0; + + $self->{+NUMBERS} = {}; + $self->{+TIMES} = Test2::Harness::Auditor::TimeTracker->new(); + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; +} + +sub pass { !$_[0]->fail } +sub file { $_[0]->{+JOB}->{file} } +sub fail { !!$_[0]->fail_error_facet_list } + +sub has_exit { defined $_[0]->{+EXIT} } +sub has_plan { defined $_[0]->{+PLAN} } + +sub process { + my $self = shift; + my ($event) = @_; + + my $f = $event->{facet_data}; + my $hf = hub_truth($f); + + my $nested = $hf->{nested} || 0; + + $self->times->process($event, $f, $self->{+ASSERTION_COUNT}) unless $nested; + + return if $hf->{buffered}; + + my $is_ours = $nested == $self->{+NESTED}; + + return unless $is_ours || $f->{from_tap}; + + # Add parent if we start a buffered subtest + if ($f->{harness} && $f->{harness}->{subtest_start}) { + my $st = $self->{+SUBTESTS}->{$nested + 1} ||= {}; + $st->{event} = $event; + $f->{harness_watcher}->{no_render} = 1; + return; + } + + my @out; + + # Not actually a subtest end, someone printed to STDOUT + if ($f->{from_tap} && $f->{harness}->{subtest_end} && !($self->{+SUBTESTS} && keys %{$self->{+SUBTESTS}})) { + # Alter $f so that this incorrect event is not sent to the renderer. + $f->{harness_watcher}->{no_render} = 1; + + # Make a new $f and $event for the rest of the processing. + $f = { + %{$f}, + harness_watcher => {added_by_watcher => 1}, + parent => undef, + trace => undef, + harness => { + %{$f->{harness} || {}}, + subtest_end => undef, + }, + info => [ + @{$f->{info} || []}, + { + details => $f->{from_tap}->{details}, + tag => $f->{from_tap}->{source} || 'STDOUT', + from_harness => 1, + } + ], + }; + + $event = Test2::Harness::Event->new(stamp => time, job_try => $self->{+TRY}, facet_data => $f); + } + + push @out => $event; + + # Close any deeper subtests + if (my $sts = $self->{+SUBTESTS}) { + my @close = sort { $b <=> $a } grep { $_ > $nested } keys %$sts; + + for my $n (@close) { + my $st = delete $sts->{$n}; + my $se = $st->{event} || $event; + + my $fd = $se->{facet_data}; + delete $fd->{harness_watcher}->{no_render}; + $fd->{parent}->{hid} ||= $n; + $fd->{parent}->{children} ||= $st->{children}; + $fd->{harness}->{closed_by} = $event; + $fd->{harness}->{closed_by_eid} = $event->{event_id}; + + my $pn = $n - 1; + + if ($st->{event}) { + if ($pn > $self->{+NESTED}) { + push @{$sts->{$pn}->{children}} => $fd; + } + elsif ($pn == $self->{+NESTED}) { + $self->subtest_process($fd, $se); + push @out => $se; + } + } + else { + push @out => $se if $self->{+NESTED} && $pn == $self->{+NESTED}; + } + } + } + + unless ($is_ours) { + my $st = $self->{+SUBTESTS}->{$nested} ||= {}; + my $fd = {%$f}; + push @{$st->{children}} => $fd; + return @out; + } + + $self->subtest_process($f, $event); + return @out; +} + +sub subtest_process { + my $self = shift; + my ($f, $event) = @_; + + my $closer = delete $f->{harness}->{closed_by}; + $event ||= Test2::Harness::Event->new(facet_data => $f, job_try => $self->{+TRY}); + + $self->{+NUMBERS}->{$f->{assert}->{number}}++ + if $f->{assert} && $f->{assert}->{number}; + + if ($f->{parent} && $f->{assert}) { + my $name = $f->{assert}->{details} // "unnamed subtest ($f->{trace}->{frame}->[1] line $f->{trace}->{frame}->[2])"; + + my $subwatcher = blessed($self)->new(nested => $self->{+NESTED} + 1, job => $self->{+JOB}, try => $self->{+TRY}); + + my $id = 1; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness}->{job_id} ||= $f->{harness}->{job_id}; + $sf->{harness}->{run_id} ||= $f->{harness}->{run_id}; + $sf->{harness}->{event_id} ||= $sf->{about}->{uuid} ||= gen_uuid(); + $subwatcher->subtest_process($sf); + } + + my @errors = $subwatcher->subtest_fail_error_facet_list(); + + if ($f->{harness}->{subtest_start}) { + push @{$f->{errors}} => {tag => 'REASON', fail => 1, from_harness => 1, details => "Buffered subtest ended abruptly (missing closing brace event)"} + unless $closer && $closer->{facet_data}->{harness}->{subtest_end}; + } + + my $fail = 0; + if (@errors) { + push @{$f->{errors}} => @errors; + $fail = 1; + } + else { + $fail ||= $f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}}); + $fail ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $fail ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + } + + if ($fail) { + $self->{+_SUB_FAILURES}++; + + # Populate the tree up to this subtest + my $tree = $self->{+FAILED_SUBTEST_TREE} //= []; + push @$tree => [$name, $subwatcher->{+FAILED_SUBTEST_TREE} // []]; + } + } + + $self->{+ASSERTION_COUNT}++ if $f->{assert}; + + if ($f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}})) { + $self->{+_FAILURES}++; + } + + if ($f->{control} || $f->{errors}) { + my $err ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $err ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + $self->{+_ERRORS}++ if $err; + $self->{+HALT} = $f->{control}->{details} || '1' if $f->{control} && $f->{control}->{halt} && (!$self->{+HALT} || $self->{+HALT} eq '1'); + } + + if ($f->{plan} && !$f->{plan}->{none}) { + $self->{+_PLANS}++; + $self->{+PLAN} = $f->{plan}; + } + + if ($f->{harness_job_exit}) { + $self->{+EXIT} = $f->{harness_job_exit}->{exit}; + + my $file = $self->file(); + + my $end = $f->{harness_job_end} = { + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + retry => $f->{harness_job_exit}->{retry}, + fail => $self->fail(), + stamp => $f->{harness_job_exit}->{stamp}, + }; + + my $plan = $self->plan; + $end->{skip} = $plan->{details} || "No reason given" if $plan && !$plan->{count}; + + my $times = $self->times; + if ($times && $times->useful) { + $end->{times} = $times->data_dump; + push @{$f->{harness_job_fields}} => $times->job_fields; + push @{$f->{info}} => {tag => 'TIME', details => $times->summary, table => $times->table}; + } + + push @{$f->{errors}} => $self->fail_error_facet_list; + } + + return; +} + +sub subtest_fail_error_facet_list { + my $self = shift; + + return @{$self->{+_SUB_INFO}} if $self->{+_SUB_INFO}; + + my @out; + + my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; + my $count = $self->{+ASSERTION_COUNT}; + + my $numbers = $self->{+NUMBERS}; + my $max = max(keys %$numbers); + if ($max) { + for my $i (1 .. $max) { + if (!$numbers->{$i}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was never seen"}; + } + elsif ($numbers->{$i} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was seen more than once"}; + } + } + } + + if (!$self->{+_PLANS}) { + if ($count) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared"}; + } + else { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared, and no assertions were made."}; + } + } + elsif ($self->{+_PLANS} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Too many plans were declared (Count: $self->{+_PLANS})"}; + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Planned for $plan assertions, but saw $self->{+ASSERTION_COUNT}"} + if $plan && $count != $plan; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Subtest failures were encountered (Count: $self->{+_SUB_FAILURES})"} + if $self->{+_SUB_FAILURES}; + + return @out; +} + +sub fail_error_facet_list { + my $self = shift; + + return @{$self->{+_INFO}} if $self->{+_INFO}; + + my @out; + + my $incomplete_subtests = values %{$self->{+SUBTESTS}}; + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "One or more incomplete subtests (Count: $incomplete_subtests)"} + if $incomplete_subtests; + + if (my $wstat = $self->{+EXIT}) { + if ($wstat == -1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "The harness could not get the exit code! (Code: $wstat)"}; + } + else { + my $e = parse_exit($wstat); + if ($e->{err}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Err: $e->{err})"}; + } + if ($e->{sig}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $e->{sig})"}; + } + } + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Errors were encountered (Count: $self->{+_ERRORS})"} + if $self->{+_ERRORS}; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion failures were encountered (Count: $self->{+_FAILURES})"} + if $self->{+_FAILURES}; + + push @out => $self->subtest_fail_error_facet_list(); + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor::Watcher - Class to monitor events for a single job and +pass judgement on the result. + +=head1 DESCRIPTION + +This module represents a per-job state tracker. This module sees every event +and manages the state produced. In the end this tracker determines if a test +job passed or failed, and why. + +=head1 SYNOPSIS + + use Test2::Harness::Auditor::Watcher; + + my $watcher = Test2::Harness::Auditor::Watcher->new(); + + for my $event (@events) { + $watcher->process($event); + } + + print "Pass!" if $watcher->pass; + print "Fail!" if $watcher->fail; + +=head1 METHODS + +=over 4 + +=item $int = $watcher->assertion_count() + +Number of assertions that have been seen. + +=item $exit = $watcher->exit() + +If the job has exited this will return the exit value (integer, 0 or greater). +If the job has not exited yet (or at least if the watcher has not seen the exit +event yet) this will return undef. + +=item $bool = $watcher->fail() + +Returns true if the job has failed/is failing. + +=item @error_facets = $watcher->fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $file = $watcher->file + +If the test file is known this will return it (string). This will return undef +if the file is not yet known. + +=item $string = $watcher->halt + +If the test was halted (bail-out) this will contain the human readible reason. + +=item $bool = $watcher->has_exit + +Check if the exit value is known. + +=item $bool = $watcher->has_plan + +Check if a plan has been seen. + +=item $job = $watcher->job + +If the job is known this will return the detailed structure of the job. + +=item $int = $watcher->nested + +If this watcher represents a subtest this will be an integer greater than 0, +the top-level test is 0. + +=item $hash = $watcher->numbers + +This is an internal state tracking what test numbers have been seen. This is +really only applicable in tests that produced TAP. + +=item $bool = $watcher->pass + +Check if the test job is passing. + +=item $plan_facet = $watcher->plan() + +If the plan facet has been seen this will return it. + +=item $watcher->process($event); + +Modify the state based on the provided event. + +=item $watcher->subtest_fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $times = $watcher->times() + +Retuns the L<Test2::Harness::Auditor::TimeTracker> instance. + +=item $int = $watcher->try() + +Sometimes a job is run more than once, in those cases this will be an integer +greater than 0 representing the try. 0 is used for the first try. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Collector.pm b/bad/Test2/Harness/Collector.pm new file mode 100644 index 000000000..fc57ae446 --- /dev/null +++ b/bad/Test2/Harness/Collector.pm @@ -0,0 +1,440 @@ +package Test2::Harness::Collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Collector::JobDir; +use Test2::Harness::State; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Time::HiRes qw/sleep time/; +use File::Spec; + +use File::Path qw/remove_tree/; + +use Test2::Harness::Util::HashBase qw{ + <run + <workdir + <run_id + <show_runner_output <truncate_runner_output <truncated_runner_output + <settings + <run_dir + <runner_pid +runner_exited <persistent_runner + + <backed_up + + +runner_stdout +runner_stderr +runner_aux_dir +runner_aux_handles + + +tasks_idx +tasks_done +tasks + +jobs_idx +jobs_done +jobs + +pending + + <wait_time + <action + <state +}; + +sub init { + my $self = shift; + + croak "'run' is required" + unless $self->{+RUN}; + + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + my $run_dir = File::Spec->catdir($self->{+WORKDIR}, $self->{+RUN_ID}); + die "Could not find run dir" unless -d $run_dir; + $self->{+RUN_DIR} = $run_dir; + + $self->{+WAIT_TIME} //= 0.02; + + $self->{+ACTION}->($self->_harness_event(0, undef, time, harness_run => $self->{+RUN}, harness_settings => $self->settings, about => {no_display => 1})); +} + +sub process { + my $self = shift; + + my %warning_seen; + my $settings = $self->settings; + + while (1) { + my $count = 0; + $count += $self->process_runner_output if $self->{+SHOW_RUNNER_OUTPUT}; + $count += $self->process_tasks(); + + my $jobs = $self->jobs; + + unless (keys %$jobs) { + next if $count; + + if ($self->persistent_runner) { + last if $self->{+JOBS_DONE}; + last if $self->runner_done; + } + + last if $self->runner_exited; + } + + while(my ($job_try, $jdir) = each %$jobs) { + $count++; + my $e_count = 0; + for my $event ($jdir->poll($self->settings->collector->max_poll_events // 1000)) { + $self->{+ACTION}->($event); + $e_count++; + } + + $count += $e_count; + next if $e_count; + my $done = $jdir->done; + unless ($done) { + $count++; + next; + } + + delete $jobs->{$job_try}; + unless ($settings->debug->keep_dirs) { + my $job_path = $jdir->job_root; + # Needed because we set the perms so that a tmpdir under it can be used. + # This is the only remove_tree that needs it because it is the + # only one in a process that did not initially create the dir. + my $ok = eval { + chmod(0700, $job_path); + remove_tree($job_path, {safe => 1, keep_root => 0}); + 1; + }; + my $err = $@; + unless ($ok) { + $count++; + unless ($warning_seen{$job_path}++) { + my $msg = "NON-FATAL Error deleting job dir ($job_path) will try again...: $err"; + my $e = $self->_harness_event(0, undef, time, info => [{details => $msg, tag => "INTERNAL", debug => 1, important => 1}]); + $self->{+ACTION}->($e); + } + next; + } + } + + delete $jobs->{$job_try}; + delete $self->{+PENDING}->{$jdir->job_id} unless $done->{retry}; + } + + last if !$count && $self->runner_exited; + sleep $self->{+WAIT_TIME} unless $count; + } + + # One last slurp + $self->process_runner_output if $self->{+SHOW_RUNNER_OUTPUT}; + + $self->{+ACTION}->(undef) if $self->{+JOBS_DONE} && $self->{+TASKS_DONE}; + + remove_tree($self->{+RUN_DIR}, {safe => 1, keep_root => 0}) unless $settings->debug->keep_dirs; + + return; +} + +sub runner_done { + my $self = shift; + + return 0 if keys %{$self->{+PENDING}}; + return 1; +} + +sub runner_exited { + my $self = shift; + my $pid = $self->{+RUNNER_PID} or return undef; + + return $self->{+RUNNER_EXITED} if $self->{+RUNNER_EXITED}; + + return 0 if kill(0, $pid); + + return $self->{+RUNNER_EXITED} = 1; +} + +sub process_runner_output { + my $self = shift; + + my $out = 0; + return $out unless $self->{+SHOW_RUNNER_OUTPUT}; + + my $action = $self->{+ACTION}; + if ($self->{+TRUNCATE_RUNNER_OUTPUT} && !$self->{+TRUNCATED_RUNNER_OUTPUT}) { + $action = sub {}; + $self->{+TRUNCATED_RUNNER_OUTPUT} = 1; + } + + my $stdout = $self->{+RUNNER_STDOUT} //= Test2::Harness::Util::File::Stream->new( + name => File::Spec->catfile($self->{+WORKDIR}, 'output.log'), + ); + + for my $line ($stdout->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => 'INTERNAL', important => 1}]); + $action->($e); + $out++; + } + + my $stderr = $self->{+RUNNER_STDERR} //= Test2::Harness::Util::File::Stream->new( + name => File::Spec->catfile($self->{+WORKDIR}, 'error.log'), + ); + + for my $line ($stderr->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => 'INTERNAL', debug => 1, important => 1}]); + $action->($e); + $out++; + } + + my $auxdir = $self->{+RUNNER_AUX_DIR} //= File::Spec->catdir($self->{+WORKDIR}, 'aux_logs'); + return $out unless -d $auxdir; + + opendir(my $dh, $auxdir) or die "Could not open aux_logs dir: $!"; + for my $path (readdir($dh)) { + next if $path =~ m/^\.+$/; + next if $self->{+RUNNER_AUX_HANDLES}->{$path}; + + my $tag = uc($path); + next unless $tag =~ s/\.LOG$//; + + my $debug = 0; + if ($tag =~ s/\W*(STDERR|STDOUT)\W*//g) { + $debug = 1 if $1 && uc($1) eq 'STDERR'; + } + + $self->{+RUNNER_AUX_HANDLES}->{$path} = { + tag => $tag, + debug => $debug, + stream => Test2::Harness::Util::File::Stream->new(name => File::Spec->catfile($auxdir, $path)), + }; + } + + for my $file (sort keys %{$self->{+RUNNER_AUX_HANDLES}}) { + my $data = $self->{+RUNNER_AUX_HANDLES}->{$file}; + my $stream = $data->{stream}; + + for my $line ($stream->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => $data->{tag}, debug => $data->{debug}, important => 1}]); + $action->($e); + $out++; + } + } + + return $out; +} + +sub process_tasks { + my $self = shift; + + return 0 if $self->{+TASKS_DONE}; + + my $queue = $self->state->data->queue->{$self->{+RUN_ID}} or return 0; + my $idx = $self->{+TASKS_IDX} //= 0; + my $list = $queue->{list} // []; + + my $count = 0; + while (@$list > $idx) { + my $task = $list->[$idx++]; + $count++; + + my $job_id = $task->{job_id} or die "No job id!"; + $self->{+TASKS}->{$job_id} = $task; + $self->{+PENDING}->{$job_id} = 1 + ($task->{retry} || $self->run->retry || 0); + + my $e = $self->_harness_event($job_id, $task->{is_try} // 0, $task->{stamp}, 'harness_job_queued' => $task); + $self->{+ACTION}->($e); + } + + $self->{+TASKS_IDX} = $idx; + if ($queue->{closed}) { + $self->{+TASKS_DONE} = 1; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->queue->{$self->{+RUN_ID}}; + }); + } + + return $count; +} + +sub send_backed_up { + my $self = shift; + return if $self->{+BACKED_UP}++; + + # This is an unlikely code path. If we're here, it means the last loop couldn't process any results. + my $e = $self->_harness_event(0, undef, time, info => [{details => <<" EOT", tag => "INTERNAL", debug => 1, important => 1}]); +*** THIS IS NOT FATAL *** + + * The collector has reached the maximum number of concurrent jobs to process. + * Testing will continue, but some tests may be running or even complete before they are rendered. + * All tests and events will eventually be displayed, and your final results will not be effected. + +Set a higher --max-open-jobs collector setting to prevent this problem in the +future, but be advised that could result in too many open filehandles on some +systems. + +This message will only be shown once. + EOT + + $self->{+ACTION}->($e); + return; +} + +sub jobs { + my $self = shift; + + my $jobs = $self->{+JOBS} //= {}; + + return $jobs if $self->{+JOBS_DONE}; + + # Don't monitor more than 'max_open_jobs' or we might have too many open file handles and crash + # Max open files handles on a process applies. Usually this is 1024 so we + # can't have everything open at once when we're behind. + my $max_open_jobs = $self->settings->collector->max_open_jobs // 1024; + my $additional_jobs_to_parse = $max_open_jobs - keys %$jobs; + if($additional_jobs_to_parse <= 0) { + $self->send_backed_up; + return $jobs; + } + + my $idx = $self->{+JOBS_IDX} //= 0; + my $jdata = $self->{+STATE}->data->jobs->{$self->{+RUN_ID}} or return $jobs; + my $list = $jdata->{list} or return $jobs; + + while (@$list > $idx) { + my $job = $list->[$idx++]; + + my $job_id = $job->{job_id} or die "No job id!"; + + die "Found job without a task!" unless $self->{+TASKS}->{$job_id}; + + $self->{+PENDING}->{$job_id}--; + delete $self->{+PENDING}->{$job_id} if $self->{+PENDING}->{$job_id} < 1; + + my $file = $job->{file}; + my $e = $self->_harness_event( + $job_id, + $job->{is_try}, + $job->{stamp}, + harness_job => $job, + harness_job_start => { + details => "Job $job_id started at $job->{stamp}", + job_id => $job_id, + stamp => $job->{stamp}, + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + }, + harness_job_launch => { + stamp => $job->{stamp}, + retry => $job->{is_try}, + }, + ); + + $self->{+ACTION}->($e); + + my $job_try = $job_id . '+' . $job->{is_try}; + + $jobs->{$job_try} = Test2::Harness::Collector::JobDir->new( + job_try => $job->{is_try} // 0, + job_id => $job_id, + run_id => $self->{+RUN_ID}, + runner_pid => $self->{+RUNNER_PID}, + job_root => File::Spec->catdir($self->{+RUN_DIR}, $job_try), + ); + } + + $self->{+JOBS_IDX} = $idx; + + if ($jdata->{closed}) { + $self->{+JOBS_DONE} = 1; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->jobs->{$self->{+RUN_ID}}; + }); + } + + # The collector didn't read in all the jobs because it'd run out of file handles. We need to let the stream know we're behind. + $self->send_backed_up if $max_open_jobs <= keys %$jobs; + + return $jobs; +} + +sub _harness_event { + my $self = shift; + my ($job_id, $job_try, $stamp, %args) = @_; + + croak "Job id is required" unless defined $job_id; + croak "Stamp is required" unless defined $stamp; + + return Test2::Harness::Event->new( + stamp => $stamp, + job_id => $job_id, + job_try => $job_try, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => \%args, + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector - Module that collects test output and provides it as +an event stream. + +=head1 DESCRIPTION + +This module is responsible for reading and parsing the output produced by +multiple jobs running under yath. + +This module is not intended for external use, it is an implementation detail +and can change at any time. Currently instances of this module are not passed +to any plugins or callbacks. + +If you need a collector for a third-party command you should look at +L<App::Yath::Command::collector>. When a command needs a collector (such as +L<App::Yath::Command::test> does) it normally spawns a collector process by +execuing C<yath collector>. The C<start_collector()> subroutine in +L<App::Yath::Command::test> is a good place to look for more details. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Collector/JobDir.pm b/bad/Test2/Harness/Collector/JobDir.pm new file mode 100644 index 000000000..cab8cf7d3 --- /dev/null +++ b/bad/Test2/Harness/Collector/JobDir.pm @@ -0,0 +1,806 @@ +package Test2::Harness::Collector::JobDir; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Errno qw/EMFILE ENFILE/; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Util qw/ipc_separator/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; +use Test2::Harness::Util qw/maybe_read_file open_file apply_encoding/; + +use Test2::Harness::Event; + +use Test2::Harness::Util::File::Stream; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Value; + +use Test2::Harness::Collector::TapParser qw{ + parse_stdout_tap + parse_stderr_tap +}; + +use Test2::Harness::Util::HashBase qw{ + <run_id <job_id <job_try <job_root <runner_pid + <done + + -_ready_buffer + + -_events_files -_events_buffer -_events_indexes -events_dir -_events_seen + + -stderr_file -_stderr_buffer -_stderr_index -_stderr_cg -_stderr_state + -stdout_file -_stdout_buffer -_stdout_index -_stdout_cg -_stdout_state + + -exit_file -_exit_done -_exit_buffer + + -et_file -et_buffer -et_done + -pet_file -pet_buffer -pet_done + + -last_stamp + + -open_errors -open_error_seen +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" + unless $self->{+RUN_ID}; + + croak "'job_id' is a required attribute" + unless $self->{+JOB_ID}; + + croak "'job_root' is a required attribute" + unless $self->{+JOB_ROOT}; + + $self->{+_EVENTS_SEEN} = {}; + + $self->{+_STDOUT_BUFFER} ||= []; + $self->{+_STDERR_BUFFER} ||= []; + $self->{+_EVENTS_BUFFER} ||= {}; + $self->{+_READY_BUFFER} ||= []; + + $self->{+LAST_STAMP} = time(); +} + +sub poll { + my $self = shift; + my ($max) = @_; + + delete $self->{+OPEN_ERRORS}; + + $self->_fill_buffers($max); + + return @{delete $self->{+OPEN_ERRORS}} if $self->{+OPEN_ERRORS}; + + my (@out, @new); + + # If we have a max number of events then we need to pass that along to the + # inner-pollers, but we need to pass around how many MORE we need, this sub + # will return the amount we still need. + # If this finds that we do not need any more it will exit the loop instead + # of returning a number. + my $check = defined($max) + ? sub { + my $want = $max - scalar(@out) - scalar(@new); + return undef if $want < 1; + return $want; + } + : sub { 1 }; + + while (!defined($max) || @out < $max) { + push @new => $self->_poll_streams($check->() // last); + + push @new => $self->_poll_timeouts($check->() // last) if $self->{+ET_BUFFER} || $self->{+PET_BUFFER}; + + # 'exit' MUST come last, so do not even think about grabbing + # them until @new is empty. + # Micro-optimization, 'exit' only ever has 1 thing, so do + # not enter the subs if we do not need to. + push @new => $self->_poll_exit($check->() // last) if !@new && defined $self->{+_EXIT_BUFFER}; + # We need to check if the runner exited BEFORE trying to check the exit value. + + last unless @new; + + push @out => @new; + @new = (); + } + + return map { + my $stamp = $_->{stamp} ? $self->{+LAST_STAMP} = $_->{stamp} : $self->{+LAST_STAMP}; + Test2::Harness::Event->new(stamp => $stamp, %{$_}); + } @out; +} + +sub _poll_streams { + my $self = shift; + my ($max) = @_; + + my $ready = $self->{+_READY_BUFFER}; + return splice(@$ready, 0, $max) unless @$ready < $max; + + my $stdout = $self->{+_STDOUT_BUFFER}; + my $stdout_cg = $self->{+_STDOUT_CG} ||= []; + my $stdout_params = { + buffer => $stdout, + comment_group => $stdout_cg, + tag => 'STDOUT', + debug => 0, + parser => \&parse_stdout_tap, + max => $max, + }; + + my $stderr = $self->{+_STDERR_BUFFER}; + my $stderr_cg = $self->{+_STDERR_CG} ||= []; + my $stderr_params = { + buffer => $stderr, + comment_group => $stderr_cg, + tag => 'STDERR', + debug => 1, + parser => \&parse_stderr_tap, + max => $max, + }; + + my $out_event = $self->_poll_stream($stdout_params); + my $err_event = $self->_poll_stream($stderr_params); + + # Once both stderr and stdout are waiting for an event we should go ahead + # and stick the events into ready. More often than not both streams will be + # waiting for the same event, the read_buffer_event logic will avoid + # duplicates. We want to call it on both buffers because some IPC + # situations can result in both streams waiting for different events. Also + # we need the sync point removed from both buffers so things can continue. + # This is an intentional bottle-neck that keeps STDOUT, STDERR, and the + # Test2 events in sync so that stderr and stdout appear where they should + # (mostly) relative to the events. This is not perfect, but it is as close + # as we can get when recombining 3+ output streams. + if ($out_event && $err_event) { + $self->_poll_streams_ready_buffer_event($stdout); + $self->_poll_streams_ready_buffer_event($stderr); + } + + if ($self->{+_EXIT_DONE} && (!$max || @$ready < $max)) { + # All done, flush the comment groups + $self->_poll_stream_flush_group($stdout_params) if @$stdout_cg; + $self->_poll_stream_flush_group($stderr_params) if @$stderr_cg; + + $self->_poll_streams_flush_events(); + } + + return splice(@$ready, 0, $max); +} + +sub _poll_streams_flush_events { + my $self = shift; + + my $buffers = $self->{+_EVENTS_BUFFER}; + for my $pid (keys %$buffers) { + for my $tid (keys %{$buffers->{$pid}}) { + my $buffer = $buffers->{$pid}->{$tid} or next; + while(my $e = shift @$buffer) { + $e = ref($e) ? $e : decode_json($e); + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); + } + } + } +} + +sub _poll_streams_ready_buffer_event { + my $self = shift; + my ($buffer) = @_; + + my $set = shift @$buffer; + my ($pid, $tid, $sid) = @$set; + + my $seen = $self->{+_EVENTS_SEEN}; + return if $seen->{$tid}->{$pid}->{$sid}; + + my $e = shift @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} or return; + $seen->{$tid}->{$pid}->{$sid} = 1; + + $e = ref($e) ? $e : decode_json($e); + + die "Stream error: Events skipped or recieved out of order ($e->{stream_id} != $sid)" + if $e->{stream_id} != $sid; + + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); +} + +sub _poll_stream_add_event { + my $self = shift; + my ($line, $params) = @_; + + my $parser = $params->{parser}; + my $tag = $params->{tag}; + my $debug = $params->{debug}; + + my $facet_data = $parser->($line); + $facet_data ||= {info => [{details => $line, tag => $tag, debug => $debug}]}; + my $event_id = $facet_data->{about}->{uuid} ||= gen_uuid(); + + push @{$self->{+_READY_BUFFER}} => { + facet_data => $facet_data, + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + }; +} + +sub _poll_stream_flush_group { + my $self = shift; + my ($params) = @_; + + my $comment_group = $params->{comment_group}; + + return unless @$comment_group; + + shift @$comment_group; # Remove the indentation state + + my $line = join "\n" => @$comment_group; + $self->_poll_stream_add_event($line, $params); + @$comment_group = (); +} + +sub _poll_stream_buffer_group { + my $self = shift; + my ($line, $params) = @_; + + return undef unless $line =~ m/^(\s*)#/; + my $indent = $1; + + my $comment_group = $params->{comment_group}; + + if (@$comment_group && $comment_group->[0] ne $indent) { + # If comment indentation has changed we do not want to append to the group + $self->_poll_stream_flush_group($params); + return 1; + } + else { + # Starting a new group + push @$comment_group => $indent; + } + + push @$comment_group => $line; + shift @{$params->{buffer}}; + return 0; +} + +sub _poll_stream { + my $self = shift; + my ($params) = @_; + + my $max = $params->{max}; + my $buff = $params->{buffer}; + my $comment_group = $params->{comment_group}; + + my $added = 0; + while (@$buff && (!$max || $added < $max)) { + my $line = $buff->[0]; + + # Already have an esync waiting + return 1 if ref $line; + + chomp($line); + + my $esync = $self->_poll_stream_process_harness_line($line, $params); + return 1 if $esync; + + # Put 'comment' lines together in a group, IE buffer this until we are done with comments + # get undef if there was no comment to buffer + # get 1 if we had to flush the buffer and start a new one + # get 0 if we did buffer the event, but no flush + my $stat = $self->_poll_stream_buffer_group($line, $params); + if (defined($stat)) { + $added += $stat; + next; + } + + # non-comment line, flush the comment group + if (@$comment_group) { + $self->_poll_stream_flush_group($params); + $added++; + next; + } + + shift @$buff; + $self->_poll_stream_add_event($line, $params); + $added++; + } + + return 0; +} + +sub _poll_stream_process_harness_line { + my $self = shift; + my ($line, $params) = @_; + + my $job_id = $self->{+JOB_ID}; + return undef unless $line =~ s/T2-HARNESS-\Q$job_id\E-(ESYNC|EVENT): (.+)//; + my ($type, $data) = ($1, $2); + + my $esync; + if ($type eq 'ESYNC') { + $esync = [split ipc_separator() => $data]; + } + elsif ($type eq 'EVENT') { + my $event_data = decode_json($data); + my $pid = $event_data->{pid}; + my $tid = $event_data->{tid}; + my $sid = $event_data->{stream_id}; + + push @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} => $event_data; + $esync = [$pid, $tid, $sid]; + } + else { + die "Unexpected harness type: $type"; + } + + # This becomes the esync, anything leftover actually belongs to the + # next line. + my $buff = $params->{buffer}; + $buff->[0] = $esync; + $buff->[1] = defined($buff->[1]) ? $line . $buff->[1] : $line if length $line; + + # Flush any comment group already buffered, an event is a sane + # boundary, not above that partial comments that might be + # interrupted by the sync point will be part of the next group + $self->_poll_stream_flush_group($params); + + return $esync; +} + +my %FILE_MAP = ( + 'stdout' => [STDOUT_FILE, \&open_file], + 'stderr' => [STDERR_FILE, \&open_file], + 'exit' => [EXIT_FILE, 'Test2::Harness::Util::File::Value'], + + 'event_timeout' => [ET_FILE, 'Test2::Harness::Util::File::Value'], + 'post_exit_timeout' => [PET_FILE, 'Test2::Harness::Util::File::Value'], +); + +sub _open_file { + my $self = shift; + my ($file) = @_; + + my $map = $FILE_MAP{$file} or croak "'$file' is not a known job file"; + my ($key, $type) = @$map; + + return $self->{$key} if $self->{$key}; + + my $path = File::Spec->catfile($self->{+JOB_ROOT}, $file); + my $out; + + if (ref $type) { + return undef unless -e $path; + return $self->{$key} = $self->try_open($path => sub { $type->($path, '<') }); + } + + return $self->{$key} = $self->try_open($path => sub { $type->new(name => $path) }); +} + +sub _fill_stream_buffers { + my $self = shift; + my ($max) = @_; + + my $stdout_state = $self->{+_STDOUT_STATE} //= {}; + my $stderr_state = $self->{+_STDERR_STATE} //= {}; + + my $stdout_buff = $self->{+_STDOUT_BUFFER} ||= []; + my $stderr_buff = $self->{+_STDERR_BUFFER} ||= []; + + my $stdout_file = $self->{+STDOUT_FILE} || $self->_open_file('stdout'); + my $stderr_file = $self->{+STDERR_FILE} || $self->_open_file('stderr'); + + return unless $stdout_file && $stderr_file; + + my @sets = grep { defined $_->[0] } ( + [$stdout_file, $stdout_buff, 'io', 'STDOUT', $stdout_state], + [$stderr_file, $stderr_buff, 'io', 'STDERR', $stderr_state], + ); + + return unless @sets; + + # Cache the result of the exists check on success, files can come into + # existence at any time though so continue to check if it fails. + while (1) { + my $added = 0; + my @events_files = $self->events_files(); + for my $set (@events_files, @sets) { + my ($file, $buff, $type, $name, $state) = @$set; + next if $max && @$buff > $max; + + my $pos = tell($file); + my $line = <$file>; + if (defined($line) && ($self->{+_EXIT_DONE} || substr($line, -1) eq "\n")) { + print "\n" if $state && delete $state->{$pos}; + + my $job_id = $self->{+JOB_ID}; + if ($type eq 'io' && $line =~ s/T2-HARNESS-\Q$job_id\E-ENCODING: (.+)\n$//) { + apply_encoding($file, $1); + } + + push @$buff => $line if length($line); + seek($file, 0, 1) if eof($file); # Reset EOF. + $added++; + } + else { + if ($name && defined($line) && $ENV{YATH_INTERACTIVE}) { + my ($fh); + + if ($name eq 'STDOUT') { + $fh = \*STDOUT; + } + elsif ($name eq 'STDERR') { + $fh = \*STDERR; + } + + my $len = length($line); + if (my $check = $state->{$pos}->{len}) { + if ($len != $check) { + delete $state->{$pos}->{done}; + $line = substr($line, $check); + } + else { + $line = "\n[INTERACTIVE] $line"; + } + } + else { + $line = "\n[INTERACTIVE] $line"; + } + + $state->{$pos}->{len} = $len; + + my $stamp = $state->{$pos}->{stamp} //= time; + my $delta = time - $stamp; + + if($delta >= 1 && !$state->{$pos}->{done}) { + $fh->autoflush(1); + + $state->{$pos}->{done} = 1; + print $fh $line; + } + } + seek($file, $pos, 0); + } + } + last unless $added; + } +} + +sub events_files { + my $self = shift; + + my $buff = $self->{+_EVENTS_BUFFER} ||= {}; + my $files = $self->{+_EVENTS_FILES} ||= {}; + + my $dir = File::Spec->catdir($self->{+JOB_ROOT}, 'events'); + return unless -d $dir; + + my $dh; + if ($self->try_open($dir => sub { opendir($dh, $dir) or die $! })) { + for my $file (readdir($dh)) { + next unless '.jsonl' eq substr($file, -6); + + next if $files->{$file}; + + my $path = File::Spec->catfile($dir, $file); + + next if $files->{$file}; + + my $fh = $self->try_open( + $path => sub { [ + split(ipc_separator() => substr(substr($file, 6 + length(ipc_separator())), 0, -6)), + open_file($path, '<'), + ] } + ); + + $files->{$file} = $fh if $fh; + } + } + + return map { [$_->[2] => $buff->{$_->[0]}->{$_->[1]} ||= [], 'jsonl'] } values %$files; +} + +sub try_open { + my $self = shift; + my ($path, $callback) = @_; + + local ($@, $?, $!, $.); + + my $out; + my $ok = eval { + $out = $callback->(); + 1; + }; + my $errno = $!; + my $err = $@; + + return $out if $ok; + + die $@ unless $errno == ENFILE || $errno == EMFILE; + + my $errors = $self->{+OPEN_ERRORS} //= []; + + unless ($self->{+OPEN_ERROR_SEEN}->{$path}++) { + push @$errors => Test2::Harness::Event->new( + stamp => time, + job_id => 0, + job_try => undef, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => { + info => [{ + details => "Could not open '$path', this is NOT FATAL as yath will try again. Errno is '$errno', Exception was: $err", + tag => 'INTERNAL', + important => 1, + }], + } + ); + } + + return undef; +} + +sub _fill_buffers { + my $self = shift; + my ($max) = @_; + # NOTE 1: 'max' will only effect stdout, stderr, and events.jsonl, the + # other files only have 1 value each so they will not eat too much memory. + # + # NOTE 2: 'max' only effects how many items are ADDED to the buffer, not + # how many are in the buffer, that is good enough, poll() will take care of + # the actual event limiting. We only use this here to make sure the buffer + # grows slowly, this is important if max is used to avoid eating memory. We + # still need to add to the buffers each time though in case we are waiting + # for a sync event before we flush. + + # Wait for the directory + return unless -d $self->{+JOB_ROOT}; + + $self->_fill_stream_buffers($max); + + # Do not look for exit until we are done with the other streams + return if $self->{+_EXIT_DONE} || @{$self->{+_STDOUT_BUFFER}} || @{$self->{+_STDERR_BUFFER}} || first { @$_ } map { values %{$_} } values %{$self->{+_EVENTS_BUFFER}}; + + $self->_open_file('event_timeout'); + $self->_open_file('post_exit_timeout'); + + my $found_timeout = 0; + for my $set ([ET_FILE, ET_BUFFER], [PET_FILE, PET_BUFFER]) { + my ($key, $buffer_key) = @$set; + next if $self->{$buffer_key}; + next unless $self->{$key} && $self->{$key}->exists; + $self->{$buffer_key} = $self->{$key}->read_line // next; + $found_timeout++; + } + + return if $found_timeout; + + return if $self->{+OPEN_ERRORS}; + + my $ended = 0; + + # We need to check if the runner exited BEFORE trying to check the exit value. + my $runner_exited = $self->{+RUNNER_PID} && !kill(0, $self->{+RUNNER_PID}); + my $exit_file = $self->{+EXIT_FILE} || $self->_open_file('exit') || return; + return if $self->{+OPEN_ERRORS}; + + if ($exit_file->exists) { + my $line = $exit_file->read_line; + if (defined($line)) { + $self->{+_EXIT_BUFFER} = $line; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + } + elsif ($runner_exited) { + $self->{+_EXIT_BUFFER} = '-1'; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + + return unless $ended; + + # If we found exit we need one last buffer fill on the other sources. + # If we do not do this we have a race condition. Ignore the max for this. + $self->_fill_stream_buffers(); +} + +sub _poll_timeouts { + my $self = shift; + + my @out; + + if (defined $self->{+ET_BUFFER} && !$self->{+ET_DONE}++) { + push @out => $self->_process_timeout_line('event' => $self->{+ET_BUFFER}, <<" EOT"); +Test2::Harness checks for timeouts at a configurable interval, if a test does +not produce any output to stdout or stderr between intervals it will be +forcefully killed under the assumption it has hung. See the '--event-timeout' +option to configure the interval. + EOT + } + + if (defined $self->{+PET_BUFFER} && !$self->{+PET_DONE}++) { + push @out => $self->_process_timeout_line('post-exit' => $self->{+ET_BUFFER}, <<" EOT"); +Sometimes tests will fork and then return. On supported systems Test2::Harness +will start all tests with their own process group and will wait for the entire +group to exit before considering the test done. In these cases Test2::Harness +will poll for output from the process group at a configurable interval, if no +output is produced between intervals the process group will be forcefully +killed. See the '--post-exit-timeout' option to configure the interval. + EOT + } + + return @out; +} + +sub _poll_exit { + my $self = shift; + # Intentionally ignoring the max argument, this only ever returns 1 item, + # and would not be called if max was 0. + + return unless defined $self->{+_EXIT_BUFFER}; + my $value = delete $self->{+_EXIT_BUFFER}; + + return $self->_process_exit_line($value); +} + +sub _process_events_line { + my $self = shift; + my ($event_data) = @_; + + $event_data->{job_id} = $self->{+JOB_ID}; + $event_data->{job_try} = $self->{+JOB_TRY}; + $event_data->{run_id} = $self->{+RUN_ID}; + $event_data->{event_id} ||= $event_data->{facet_data}->{about}->{uuid} ||= gen_uuid(); + + return $event_data; +} + +sub _process_exit_line { + my $self = shift; + my ($value) = @_; + + chomp($value); + + my $stdout = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stdout")); + my $stderr = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stderr")); + + $stdout =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + $stderr =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + + my $event_id = gen_uuid(); + + my ($exit, $err, $sig, $dmp, $stamp, $retry) = (split(/\s+/, $value), '', '', '', '', '', ''); + + $self->{+DONE} = {retry => $retry}; + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id}, + harness_job_exit => { + details => "Test script exited $exit ($err\:$sig)", + exit => $exit, + code => $err, + signal => $sig, + dumped => $dmp, + retry => $retry, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + stdout => $stdout, + stderr => $stderr, + stamp => $stamp, + line => $value, + }, + } + }; +} + +sub _process_timeout_line { + my $self = shift; + my ($type, $buffer, $reason) = @_; + + chomp($buffer //= ''); + my ($stamp, $delta) = split /\s+/, $buffer; + $stamp //= time(); + $delta = defined($delta) ? sprintf('%.4f', $delta) : '??'; + + my $event_id = gen_uuid(); + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id, details => "Timeout ($type)"}, + errors => [ + { + tag => 'TIMEOUT', + details => "A timeout ($type) has occured (after $delta seconds), job was forcefully killed", + fail => 1, + }, + ], + info => [ + { + tag => 'TIMEOUT', + debug => 1, + important => 1, + details => $reason, + }, + ], + } + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::JobDir - Job Directory Parser, read events from an active +jobs output directory. + +=head1 DESCRIPTION + +This module is responsible for reading and parsing a running jobs output +directory. The result is an event stream. + +This module is not intended for external use, it is an implementation detail +and can change at any time. Currently instances of this module are not passed +to any plugins or callbacks. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Collector/TapParser.pm b/bad/Test2/Harness/Collector/TapParser.pm new file mode 100644 index 000000000..39520ef97 --- /dev/null +++ b/bad/Test2/Harness/Collector/TapParser.pm @@ -0,0 +1,383 @@ +package Test2::Harness::Collector::TapParser; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer 'Importer' => 'import'; + +our @EXPORT_OK = qw{ + parse_stdout_tap + parse_stderr_tap + parse_tap_line +}; + +sub parse_stdout_tap { + my ($line) = @_; + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{from_tap} = { source => 'STDOUT', details => $line }; + return $facet_data; +} + + +sub parse_stderr_tap { + my ($line) = @_; + + # STDERR only has comments + return unless $line =~ m/^\s*#/; + + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{info}->[-1]->{tag} = 'DIAG'; + $facet_data->{info}->[-1]->{debug} = 1; + $facet_data->{from_tap} = { source => 'STDERR', details => $line }; + + return $facet_data; +} + +sub parse_tap_line { + my ($line) = @_; + return __PACKAGE__->_parse_tap_line($line); +} + +sub _parse_tap_line { + my $class = shift; + my ($line) = @_; + chomp($line); + + my ($lead, $lead_len, $nest, $str) = ('', 0, 0, $line); + if ($line =~ m/^(\s+)\S/) { + $lead = $1; + $str =~ s/^\Q$lead\E//mg; + + $lead =~ s/\t/ /g; + $lead_len = length($lead); + + # indentation other than 0 or a multiple of 4 spaces... not an event + return undef if $lead_len % 4; + + $nest = $lead_len / 4; + } + + my @types = qw/buffered_subtest comment plan bail version/; + for my $type (@types) { + my $sub = "parse_tap_$type"; + my $facet_data = $class->$sub($str) or next; + $facet_data->{trace}->{nested} = $nest; + $facet_data->{hubs}->[0]->{nested} = $nest; + return $facet_data; + } + + return undef; +} + +sub parse_tap_buffered_subtest { + my $class = shift; + my ($line) = @_; + + # End of a buffered subtest. + return {parent => {}, harness => {subtest_end => 1}} if $line =~ m/^\}\s*$/; + + my $facet_data = $class->parse_tap_ok($line) or return undef; + return $facet_data unless $facet_data->{assert}->{details} =~ s/\s*\{\s*$//g; + + $facet_data->{parent} = { + details => $facet_data->{assert}->{details}, + }; + $facet_data->{harness}->{subtest_start} = 1; + + return $facet_data; +} + +sub parse_tap_ok { + my $class = shift; + my ($line) = @_; + + my ($pass, $todo, $skip, $num, @errors); + + return undef unless $line =~ s/^(not )?ok\b//; + $pass = !$1; + + push @errors => "'ok' is not immediately followed by a space." + if $line && !($line =~ m/^ /); + + if ($line =~ s/^(\s*)(\d+)\b//) { + my $space = $1; + $num = $2; + + push @errors => "Extra space after 'ok'" + if length($space) > 1; + } + + # Not strictly compliant, but compliant with what Test-Simple does... + # Standard does not have a todo & skip. + if ($line =~ s/#\s*(todo & skip|todo|skip)(.*)$//i) { + my ($directive, $reason) = ($1, $2); + + push @errors => "No space before the '#' for the '$directive' directive." + unless $line =~ s/\s+$//; + + push @errors => "No space between '$directive' directive and reason." + if $reason && !($reason =~ s/^\s+//); + + $skip = $reason if $directive =~ m/skip/i; + $todo = $reason if $directive =~ m/todo/i; + } + + # Standard says that everything after the ok (except the number) is part of + # the name. Most things add a dash between them, and I am deviating from + # standards by stripping it and surrounding whitespace. + $line =~ s/\s*-\s*//; + + $line =~ s/^\s+//; + $line =~ s/\s+$//; + + my $is_subtest = ($line =~ m/^Subtest:\s*(.*)$/) ? ($1 or 1) : undef; + + my $facet_data = { + assert => { + pass => $pass, + no_debug => 1, + details => $line, + defined $num ? (number => $num) : (), + }, + }; + + $facet_data->{parent} = { + details => $is_subtest, + } if defined $is_subtest; + + push @{$facet_data->{amnesty}} => { + tag => 'SKIP', + details => $skip, + } if defined $skip; + + push @{$facet_data->{amnesty}} => { + tag => 'TODO', + details => $todo, + } if defined $todo; + + push @{$facet_data->{info}} => { + details => $_, + debug => 1, + tag => 'PARSER', + } for @errors; + + return $facet_data; +} + +sub parse_tap_version { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^TAP version\s/; + + return { + about => { + details => $line, + }, + info => [ + { + tag => 'INFO', + debug => 0, + details => $line, + } + ], + }; +} + +sub parse_tap_plan { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ s/^1\.\.(\d+)//; + my $max = $1; + + my ($directive, $reason) = ("", ""); + + if ($max == 0) { + if ($line =~ s/^\s*#\s*//) { + if ($line =~ s/^(skip)\S*\s*//i) { + $directive = uc($1); + $reason = $line; + $line = ""; + } + } + + $directive ||= "SKIP"; + $reason ||= "no reason given"; + } + + my $facet_data = { + plan => { + count => $max, + skip => ($directive eq 'SKIP') ? 1 : 0, + details => $reason, + } + }; + + push @{$facet_data->{info}} => { + details => 'Extra characters after plan.', + debug => 1, + tag => 'PARSER', + } if $line =~ m/\S/; + + return $facet_data; +} + +sub parse_tap_bail { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^Bail out!\s*(.*)$/; + + return { + control => { + halt => 1, + details => $1, + } + }; +} + +sub parse_tap_comment { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^\s*#/; + + $line =~ s/^\s*# ?//msg; + + return { + info => [ + { + details => $line, + tag => 'NOTE', + debug => 0, + } + ] + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::TapParser - Produce EventFacets from a line of TAP. + +=head1 DESCRIPTION + +This module is responsible for reading and processing any TAP output from +tests. Lines of TAP output are processed into L<Test2::Event> facet data. Note +that C<< Test2 -> TAP -> Test2 >> is lossy at the C<< Test2 -> TAP >> step. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::TapParser qw/parse_tap_line/; + + my $facet_data = parse_tap_line("1..1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + plan => { + details => '', + count => 1, + skip => 0, + }, + }, + "Parsed the plan" + ); + + $facet_data = parse_tap_line("# foo"); + is( + $facet_data, + { + trace => { nested => 0 }, + hubs => [ { nested => 0 } ], + info => [ + { + tag => 'NOTE', + details => 'foo', + debug => 0, + }, + ], + }, + + "Parsed the note" + ); + + $facet_data = parse_tap_line("ok 1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + assert => { + no_debug => 1, + pass => 1, + number => '1', + details => '', + }, + }, + "Parsed the assertion" + ); + +=head1 EXPORTS + +=over 4 + +=item $facet_data = parse_tap_line($line) + +Parse a line of TAP. It is assumed to be STDOUT thus all comments are turned +into notes. Using this export will B<NOT> add the usual C<from_tap> facet. It +is better to use one of the other 2 exports. + +=item $facet_data = parse_stdout_tap($line) + +Parse a line of TAP from stdout. + +=item $facet_data = parse_stderr_tap($line) + +Parse a line of TAP from stderr. This will B<ONLY> parse comment lines (ones +that start with a C<#>, which may be indented). All comments will be treated as +diag's, all other lines will be ignored. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Event.pm b/bad/Test2/Harness/Event.pm new file mode 100644 index 000000000..5f207ce2d --- /dev/null +++ b/bad/Test2/Harness/Event.pm @@ -0,0 +1,216 @@ +package Test2::Harness::Event; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::JSON qw/encode_json/; + +use Importer 'Test2::Util::Facets2Legacy' => ':ALL'; + +BEGIN { + require Test2::Event; + our @ISA = ('Test2::Event'); + + # Currently the base class for events does not have init(), that may change + if (Test2::Event->can('init')) { + *INIT_EVENT = sub() { 1 } + } + else { + *INIT_EVENT = sub() { 0 } + } +} + +use Test2::Harness::Util::HashBase qw{ + <facet_data + <stream_id + <event_id + <run_id + <job_id + <job_try + <stamp + +json + processed +}; + +sub trace { $_[0]->{+FACET_DATA}->{trace} } +sub set_trace { confess "'trace' is a read only attribute" } + +sub init { + my $self = shift; + + $self->Test2::Event::init() if INIT_EVENT; + + my $data = $self->{+FACET_DATA} || confess "'facet_data' is a required attribute"; + + for my $field (RUN_ID(), JOB_ID(), JOB_TRY(), EVENT_ID()) { + my $v1 = $self->{$field}; + my $v2 = $data->{harness}->{$field}; + + my $d1 = defined($v1); + my $d2 = defined($v2); + + confess "'$field' is a required attribute" + unless $d1 || $d2 || ($field eq +JOB_TRY && !$self->{+JOB_ID}); + + confess "'$field' has different values between attribute and facet data" + if $d1 && $d2 && $v1 ne $v2; + + $self->{$field} = $data->{harness}->{$field} = $v1 // $v2; + } + + delete $data->{facet_data}; + + # Original trace wins. + if (my $trace = delete $self->{+TRACE}) { + $self->{+FACET_DATA}->{trace} //= $trace; + } +} + +sub as_json { $_[0]->{+JSON} //= encode_json($_[0]) } + +sub TO_JSON { + my $out = {%{$_[0]}}; + + $out->{+FACET_DATA} = { %{$out->{+FACET_DATA}} }; + delete $out->{+FACET_DATA}->{harness_job_watcher}; + delete $out->{+FACET_DATA}->{harness}->{closed_by}; + delete $out->{+JSON}; + delete $out->{+PROCESSED}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Event - Subclass of Test2::Event used by Test2::Harness under +the hood. + +=head1 DESCRIPTION + +Test2 tests produce a sequence of events objects L<Test2::Event>. This is a +subclass of those events for use in L<Test2::Harness>. Event non-test tests +which produce TAP output will have the output parsed into these types of +events. + +=head1 SYNOPSIS + +In normal usage ou will never need to create one fo these events yourself. This +documentation assumes you are operating on an existing event C<$event> that the +harness exposed to you via a plugin or similar. + + my $facet_data = $event->facet_data; + my $run_id = $event->run_id; + my $job_id = $event->job_id; + my $job_try = $event->job_try; + my $event_id = $event->event_id; + +=head1 METHODS + +See L<Test2::Event> for methods provided by the base class. + +=over 4 + +=item $hashref = $event->TO_JSON + +Used for json serialization. + +=item $json_string = $event->as_json + +This will return a json representation of the event. Note that this is a lossy +conversion with some harness specific state removed by design. This may even be +a cached copy of the json string that was decoded to produce the original +object. If the string was not cached before it will be cached for all future +calls ignoring any state change to the event. + +The lossy/cached conversion is intended so that events get passed through the +harness pipeline without modifications from one step translating to another. If +you need something extra to go through you need to either replace the event or +create an additional one. + +=item $string = $event->event_id + +Usually a UUID, but not always! + +=item i$hashref = $event->facet_data + +Get the event facet data, this is the meat of the event that hold all the +state. + +=item $string = $event->job_id + +Usually a UUID, but not always! + +=item $int = $event->job_try + +Integer, 0 or greater. Some jobs are run additional times if they fail, this +says which attempt the event is for. The counter starts at 0. + +=item $bool = $event->processed + +This will be true if the event has been process by the harness. Note that this +attibute is not serialized by C<TO_JSON> or C<as_json>. + +=item $string = $event->run_id + +The run id. This is usually a UUID, but not always! + +=item $ts = $event->stamp + +A unix timestamp for when the event was created. + +=item $id = $event->stream_id + +This is an implementation detail of L<Test2::Formatter::Stream>, do not rely on +it. This is used to prevent parsing errors when stream output is nested in +other stream output, which can happen if you are writing tests for the stream +formatter itself. + +=item $trace = $event->trace + +This si a shortcut for C<< $event->facet_data->{trace} >>. The trace data is +essential and used everywhere. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Finder.pm b/bad/Test2/Harness/Finder.pm new file mode 100644 index 000000000..093dd8f93 --- /dev/null +++ b/bad/Test2/Harness/Finder.pm @@ -0,0 +1,940 @@ +package Test2::Harness::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use List::Util qw/first/; +use Cwd qw/getcwd/; +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Text::ParseWords qw/quotewords/; + +use Test2::Harness::TestFile; +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <default_search <default_at_search + + <durations <maybe_durations +duration_data <durations_threshold + + <exclude_files <exclude_patterns <exclude_lists + + <no_long <only_long + + <rerun <rerun_modes <rerun_plugin + + search <extensions + + <multi_project + + <changed <changed_only <changes_plugin <show_changed_files <changes_diff + <changes_filter_file <changes_filter_pattern + <changes_exclude_file <changes_exclude_pattern + <changes_include_whitespace <changes_exclude_nonsub + <changes_exclude_loads <changes_exclude_opens +}; + +sub munge_settings {} + +sub init { + my $self = shift; + + $self->{+EXCLUDE_FILES} = { map {( $_ => 1 )} @{$self->{+EXCLUDE_FILES}} } if ref($self->{+EXCLUDE_FILES}) eq 'ARRAY'; + + if (my $plugins = $self->{+RERUN_PLUGIN}) { + for (@$plugins) { + $_ = "App::Yath::Plugin::$_" unless s/^\+// or m/^(App::Yath|Test2::Harness)::Plugin::/; + my $file = mod2file($_); + require $file; + } + } +} + +sub duration_data { + my $self = shift; + my ($plugins, $settings, $test_files) = @_; + + $self->{+DURATION_DATA} //= $self->pull_durations(); + + return $self->{+DURATION_DATA} if $self->{+DURATION_DATA}; + + for my $plugin (@$plugins) { + next unless $plugin->can('duration_data'); + $self->{+DURATION_DATA} = $plugin->duration_data($settings, $test_files) or next; + last; + } + + return $self->{+DURATION_DATA} //= {}; +} + +sub pull_durations { + my $self = shift; + + my $primary = delete $self->{+MAYBE_DURATIONS}; + my $fallback = delete $self->{+DURATIONS}; + + my @args = ( + name => 'durations', + is_json => 1, + http_args => [{headers => {'Content-Type' => 'application/json'}}], + ); + + if ($primary) { + local $@; + + my $durations = eval { $self->_pull_from_file_or_url(source => $primary, @args) } + or print "Could not fetch optional durations '$primary', ignoring...\n"; + + if ($durations) { + print "Found durations: $primary\n"; + return $durations; + } + } + + return $self->_pull_from_file_or_url(source => $fallback, @args) + if $fallback; + + return; +} + +sub add_exclusions_from_lists { + my $self = shift; + + my @lists = ref($self->{+EXCLUDE_LISTS}) eq 'ARRAY' ? @{$self->{+EXCLUDE_LISTS}} : ($self->{+EXCLUDE_LISTS}); + + for my $path (@lists) { + my $content = $self->_pull_from_file_or_url( + source => $path, + name => 'exclusion lists', + ); + + next unless $content; + + for (split(/\r?\n\r?/, $content)) { + $self->{+EXCLUDE_FILES}->{$_} = 1 unless /^\s*#/; + }; + } +} + +sub _pull_from_file_or_url { + my $self = shift; + my %params = @_; + + my $in = $params{source} // croak "No file or url provided"; + my $name = $params{name} // croak "No name provided"; + + my $is_json = $params{is_json}; + + if (my $type = ref($in)) { + return $in if $is_json && ($type eq 'HASH' || $type eq 'ARRAY'); + } + elsif (-f $in) { + if ($is_json) { + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => $in); + return $file->read(); + } + else { + require Test2::Harness::Util::File; + my $f = Test2::Harness::Util::File->new(name => $in); + return $f->read(); + } + } + elsif ($in =~ m{^https?://}) { + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args}; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + my $res = $ht->$meth($in, $args ? (@$args) : ()); + + die "Could not query $name from '$in'\n$res->{status}: $res->{reason}\n$res->{content}\n" + unless $res->{success}; + + return $is_json ? decode_json($res->{content}) : $res->{content}; + } + + die "Invalid $name specification: $in"; +} + +sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + $self->add_exclusions_from_lists() if $self->{+EXCLUDE_LISTS}; + + my $add_changes = 0; + $add_changes ||= $self->{+CHANGED} && @{$self->{+CHANGED}}; + $add_changes ||= $self->{+CHANGED_ONLY}; + $add_changes ||= $self->{+CHANGES_PLUGIN}; + $add_changes ||= $self->{+CHANGES_DIFF}; + + $self->add_changed_to_search($plugins, $settings) if $add_changes; + + my $add_rerun = $self->{+RERUN}; + $self->add_rerun_to_search($plugins, $settings, $add_rerun) if $add_rerun; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + + return $self->find_project_files($plugins, $settings, $self->search); +} + +sub check_plugins { + my $self = shift; + my ($plugins, $settings) = @_; + + my $check_plugins = $plugins; + my $plugin; + if (my $p = $self->{+CHANGES_PLUGIN}) { + $plugin = $p =~ s/^\+// ? $p : "App::Yath::Plugin::$p"; + $check_plugins = [$plugin]; + } + + return $check_plugins // []; +} + +sub get_diff { + my $self = shift; + my ($plugins, $settings) = @_; + + return (file => $self->{+CHANGES_DIFF}) if $self->{+CHANGES_DIFF}; + + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + if ($plugin->can('changed_diff')) { + my ($type, $data) = $plugin->changed_diff($settings); + next unless $type && $data; + + return ($type => $data); + } + } + + return (); +} + +sub find_changes { + my $self = shift; + my ($plugins, $settings) = @_; + + my @listed_changes = @{$self->{+CHANGED}} if $self->{+CHANGED}; + + my ($type, $diff) = $self->get_diff($plugins, $settings); + + my (@found_changes); + if ($type && $diff) { + @found_changes = $self->changes_from_diff($type => $diff, $settings); + } + + unless (@found_changes) { + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + next unless $plugin->can('changed_files'); + + push @found_changes => $plugin->changed_files($settings); + last if @found_changes; + } + } + + my $filter_patterns = @{$self->{+CHANGES_FILTER_PATTERN}} ? $self->{+CHANGES_FILTER_PATTERN} : undef; + my $filter_files = @{$self->{+CHANGES_FILTER_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_FILTER_FILE}}} : undef; + + my $exclude_patterns = @{$self->{+CHANGES_EXCLUDE_PATTERN}} ? $self->{+CHANGES_EXCLUDE_PATTERN} : undef; + my $exclude_files = @{$self->{+CHANGES_EXCLUDE_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_EXCLUDE_FILE}}} : undef; + + my %changed_map; + for my $change (@listed_changes, @found_changes) { + next unless $change; + my ($file, @parts) = ref($change) ? @$change : ($change); + + next if $filter_files && !$filter_files->{$file}; + next if $exclude_files && $exclude_files->{$file}; + next if $filter_patterns && !first { $file =~ m/$_/ } @$filter_patterns; + next if $exclude_patterns && first { $file =~ m/$_/ } @$exclude_patterns; + + @parts = ('*') unless @parts; + $changed_map{$file}{$_} = 1 for @parts; + } + + return \%changed_map; +} + +sub get_capable_plugins { + my $self = shift; + my ($method, $plugins) = @_; + + my %seen; + return grep { $_ && !$seen{$_}++ && $_->can($method) } @$plugins; +} + +sub add_rerun_to_search { + my $self = shift; + my ($plugins, $settings, $rerun) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $modes = $self->{+RERUN_MODES}; + my $mode_hash = { map {$_ => 1} @$modes }; + + my ($grabbed, $data); + for my $p ($self->get_capable_plugins(grab_rerun => [@{$self->{+RERUN_PLUGIN} // []}, @$plugins])) { + ($grabbed, $data) = $p->grab_rerun($rerun, modes => $modes, mode_hash => $mode_hash, settings => $settings); + next unless $grabbed; + + unless ($data && keys %$data) { + print "No files found to rerun.\n"; + exit 0; + } + + last if $grabbed; + } + + unless ($grabbed) { + if ($rerun eq '1') { + $rerun = first { -e $_ } qw{ ./lastlog.jsonl ./lastlog.jsonl.bz2 ./lastlog.jsonl.gz }; + + die "Could not find a lastlog.jsonl(.bz2|.gz) file for re-running, you may need to provide a full path to --rerun=... or --rerun-failed=..." + unless $rerun; + } + + die "'$rerun' is not a valid log file, and no plugin intercepted it.\n" unless -f $rerun; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $rerun, skip_bad_decode => 1); + + my %files; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $f = $event->{facet_data} or next; + + for my $type (qw/seen queued start end/) { + my $field = $type eq 'seen' ? "harness_job" : "harness_job_$type"; + + my $data = $f->{$field} or next; + + my $file = $data->{rel_file} // $data->{run_file} // $data->{file} // $data->{abs_file}; + next unless $file; + + my $ref = $files{$file} //= {}; + $ref->{$type}++; + + $ref->{$data->{fail} ? 'fail' : 'pass'}++ if $type eq 'end'; + $ref->{retry}++ if $data->{is_try}; + } + } + } + + $data = \%files; + } + + my @add = map { $data->{$_}->{add} // $_ } grep { + my $entry = $data->{$_}; + + my $keep = $mode_hash->{all} ? 1 : 0; + $keep ||= 1 if $mode_hash->{failed} && $entry->{fail} && !$entry->{pass}; + $keep ||= 1 if $mode_hash->{retried} && $entry->{retry}; + $keep ||= 1 if $mode_hash->{passed} && $entry->{pass}; + $keep ||= 1 if $mode_hash->{missed} && !$entry->{end}; + + $keep + } sort keys %$data; + + unless (@add) { + print "No files found to rerun.\n"; + exit 0; + } + + push @$search => @add; +} + +sub add_changed_to_search { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $changed_map = $self->find_changes($plugins, $settings); + my $found_changed = keys %$changed_map; + + die "Could not find any changed files.\n" if $self->{+CHANGED_ONLY} && !$found_changed; + + if ($self->{+CHANGED_ONLY}) { + die "Can not add test or directory names when using --changed-only (saw: " . join(", " => @$search) . ")\n" + if @$search; + } + + if ($self->{+SHOW_CHANGED_FILES} && $found_changed) { + print "Found the following changed files:\n"; + for my $file (keys %$changed_map) { + print " $file: ", join(", ", sort keys %{$changed_map->{$file}}), "\n"; + } + } + + my @add; + for my $p ($self->get_capable_plugins(get_coverage_tests => $plugins)) { + for my $set ($p->get_coverage_tests($settings, $changed_map)) { + my $test = ref($set) ? $set->[0] : $set; + + unless (-e $test) { + print STDERR "Coverage wants to run test '$test', but it does not exist, skipping...\n"; + next; + } + + push @add => $set; + } + } + + for my $p ($self->get_capable_plugins(post_process_coverage_tests => $plugins)) { + $p->post_process_coverage_tests($settings, \@add); + } + + if ($self->{+SHOW_CHANGED_FILES} && @add) { + print "Found " . scalar(@add) . " test files to run based on changed files.\n"; + print ref($_) ? " $_->[0]" : " $_\n" for @add; + print "\n"; + } + + push @$search => @add; + + return; +} + +sub changes_from_diff { + my $self = shift; + my ($type, $data, $settings) = @_; + + my $next; + if ($type eq 'lines') { + $next = sub { shift @$data }; + } + elsif ($type eq 'diff') { + my $lines = [split /\n/, $data]; + $next = sub { shift @$lines }; + } + elsif ($type eq 'file') { + die "'$data' is not a valid diff file.\n" unless -f $data; + open(my $fh, '<', $data) or die "Could not open diff file '$data': $!"; + $next = sub { + my $line = <$fh>; + close($fh) unless defined $line; + return $line; + }; + } + elsif ($type eq 'line_sub') { + $next = $data; + } + elsif ($type eq 'handle') { + $next = sub { scalar <$data> }; + } + else { + die "Invalid diff type '$type'"; + } + + my %changed; + + # Only perl can parse perl, and nothing can parse perl diff. What this does + # is take a diff of every file with 100% context so we see the entire file + # with the +, minus, or space prefix. As we scan it we look for subs. We + # track what files and subs we are in. When we see a change we + # {$file}{$sub}++. + # + # This of course is broken if you make a change between + # subs as it will attribute it to the previous sub, however tracking + # indentation is equally flawed as things like heredocs and other special + # perl things can also trigger that to prematurely think we are out of a + # sub. + # + # PPI and similar do a better job parsing perl, but using them and also + # tracking changes from the diff, or even asking them to parse a diff where + # some lines are added and others removed is also a huge hassle. + # + # The current algorith is "good enough", not perfect. + my ($file, $sub, $indent, $is_perl); + while (my $line = $next->()) { + chomp($line); + if ($line =~ m{^(?:---|\+\+\+) ([ab]/)?(.*)$}) { + my $maybe_prefix = $1; + my $maybe_file = $2; + next if $maybe_file =~ m{/dev/null}; + if ($maybe_prefix) { + $file = -f "$maybe_prefix$maybe_file" ? "$maybe_prefix$maybe_file" : $maybe_file; + } + else { + $file = $maybe_file; + } + $is_perl = 1 if $file =~ m/\.(pl|pm|t2?)$/; + $sub = '*'; # Wildcard, changes to the code outside of a sub potentially effects all subs + next; + } + + next unless $file; + + $line =~ m/^( |-|\+)(.*)$/ or next; + my ($prefix, $statement) = ($1, $2); + my $changed = $prefix eq ' ' ? 0 : 1; + + $is_perl = 1 if $statement =~ m/^#!.*perl/; + + if ($statement =~ m/^(\s*)sub\s+(\w+)/) { + $indent = $1 // ''; + $sub = $2; + + # 1-line sub: sub foo { ... } + if ($statement =~ m/}/) { + $changed{$file}{$sub}++ if $changed; + $sub = '*'; + $indent = undef; + next; + } + } + elsif(defined($indent) && $statement =~ m/^$indent\}/) { + $indent = undef; + $sub = "*"; + + # If this is nothing but whitespace and a closing paren we can skip it. + next if $statement =~ m/^\s*\}?\s*$/ && !$self->{+CHANGES_INCLUDE_WHITESPACE}; + } + + next unless $sub; # If sub is empty then we are not even in a file yet + next unless $changed; # If we are not on a changed line no need to add it + unless ($self->{+CHANGES_INCLUDE_WHITESPACE}) { + next if !length($statement); # If there is no statement length then this is whitespace only + next if $statement =~ m/^\s+$/; # Do not care about whitespace only changes + } + + next if $is_perl && $self->{+CHANGES_EXCLUDE_NONSUB} && $sub eq '*'; + + $changed{$file}{$sub}++; + } + + return map {([$_ => sort keys %{$changed{$_}}])} sort keys %changed; +} + + +sub find_multi_project_files { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search // []; + + die "multi-project search must be a single directory, or the current directory" if @$search > 1; + my ($pdir) = @$search; + my $dir = clean_path(getcwd()); + + my $out = []; + my $ok = eval { + chdir($pdir) if defined $pdir; + my $ret = clean_path(getcwd()); + + opendir(my $dh, '.') or die "Could not open project dir: $!"; + for my $subdir (readdir($dh)) { + chdir($ret); + + next if $subdir =~ m/^\./; + my $path = clean_path(File::Spec->catdir($ret, $subdir)); + next unless -d $path; + + chdir($path) or die "Could not chdir to $path: $!\n"; + + for my $item (@{$self->find_project_files($plugins, $settings, [])}) { + push @{$item->queue_args} => ('ch_dir' => $path); + push @$out => $item; + } + } + + chdir($ret); + 1; + }; + my $err = $@; + + chdir($dir); + die $err unless $ok; + + return $out; +} + +sub find_project_files { + my $self = shift; + my ($plugins, $settings, $input) = @_; + + $input //= []; + $plugins //= []; + + my $default_search = [@{$self->default_search}]; + push @$default_search => @{$self->default_at_search} if $settings->check_prefix('run') && $settings->run->author_testing; + + $_->munge_search($input, $default_search, $settings) for @$plugins; + + my $search = @$input ? $input : $self->{+CHANGED_ONLY} ? [] : $default_search; + + die "No tests to run, search is empty\n" unless @$search; + + + my (%seen, @tests, @dirs); + + for my $item (@$search) { + my ($path, $test_params); + + if (ref $item) { + ($path, $test_params) = @$item; + } + else { + my ($type, $data); + ($path, $type, $data) = split /(:<|:@|:=)/, $item, 2; + if ($type && $data) { + $test_params = {}; + if ($type eq ':<') { + $test_params->{stdin} = $data; + } + elsif ($type eq ':@') { + $test_params->{argv} = decode_json($data); + } + elsif ($type eq ':=') { + $test_params->{env} = decode_json($data); + } + } + } + + push @dirs => $path and next if -d $path; + + unless(-f $path) { + my ($actual, $args) = split /=/, $path, 2; + if (-f $actual) { + $path = $actual; + $test_params = {%{$test_params // {}}, argv => [quotewords('\s+', 0, $args)]}; + } + else { + die "'$path' is not a valid file or directory.\n" if @$input; + next; + } + } + + $path = clean_path($path, 0); + $seen{$path}++; + + my $test; + unless (first { $test = $_->claim_file($path, $settings, from => 'listed') } @$plugins) { + $test = Test2::Harness::TestFile->new(file => $path); + } + + if (my @exclude = $self->exclude_file($test)) { + if (@$input) { + print STDERR "File '$path' was listed on the command line, but has been exluded for the following reasons:\n"; + print STDERR " $_\n" for @exclude; + } + + next; + } + + if ($test_params) { + $test->set_input($test_params->{stdin}) if $test_params->{stdin}; + $test->set_test_args($test_params->{argv}) if $test_params->{argv}; + $test->set_env_vars($test_params->{env}) if $test_params->{env}; + } + + push @tests => $test; + } + + if (@dirs) { + require File::Find; + File::Find::find( + { + no_chdir => 1, + wanted => sub { + no warnings 'once'; + + my $file = clean_path($File::Find::name, 0); + + return if $seen{$file}++; + return unless -f $file; + + my $test; + unless(first { $test = $_->claim_file($file, $settings, from => 'search') } @$plugins) { + for my $ext (@{$self->extensions}) { + next unless m/\.\Q$ext\E$/; + $test = Test2::Harness::TestFile->new(file => $file); + last; + } + } + + return unless $test; + return unless $self->include_file($test); + push @tests => $test; + }, + }, + @dirs + ); + } + + my $test_count = @tests; + my $threshold = $settings->finder->durations_threshold // 0; + if ($threshold && $test_count >= $threshold) { + my $start = time; + my $durations = $self->duration_data($plugins, $settings, [map { $_->relative } @tests]); + my $end = time; + if ($durations && keys %$durations) { + printf("Fetched duration data (Took %0.2f seconds)\n", $end - $start); + for my $test (@tests) { + my $rel = $test->relative; + $test->set_duration($durations->{$rel}) if $durations->{$rel}; + } + } + } + + $_->munge_files(\@tests, $settings) for @$plugins; + + return [ sort { $a->rank <=> $b->rank || $a->file cmp $b->file } @tests ]; +} + +sub include_file { + my $self = shift; + my ($test) = @_; + + my @exclude = $self->exclude_file($test); + + return !@exclude; +} + +sub exclude_file { + my $self = shift; + my ($test) = @_; + + my @out; + + push @out => "File has a do-not-run directive inside it." unless $test->check_feature(run => 1); + + my $full = $test->file; + my $rel = $test->relative; + + push @out => 'File is in the exclude list.' if $self->exclude_files->{$full} || $self->exclude_files->{$rel}; + push @out => 'File matches an exclusion pattern.' if first { $rel =~ m/$_/ } @{$self->exclude_patterns}; + + push @out => 'File is marked as "long", but the "no long tests" opition was specified.' + if $self->no_long && $test->check_duration eq 'long'; + + push @out => 'File is not marked "long", but the "only long tests" option was specified.' + if $self->only_long && $test->check_duration ne 'long'; + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Finder - Library that searches for test files + +=head1 DESCRIPTION + +The finder is responsible for locating test files that should be run. You can +subclass the finder and instruct yath to use your subclass. + +=head1 SYNOPSIS + +=head2 USING A CUSTOM FINDER + +To use Test2::Harness::Finder::MyFinder: + + $ yath test --finder MyFinder + +To use Another::Finder + + $ yath test --finder +Another::Finder + +By default C<Test2::Harness::Finder::> is prefixed onto your custom finder, use +'+' before the class name or prevent this. + +=head2 SUBCLASSING + + use parent 'Test2::Harness::Finder'; + use Test2::Harness::TestFile; + + # Custom finders may provide their own options if desired. + # This is optional. + use App::Yath::Options; + option foo => ( + ... + ); + + # This is the main method to override. + sub find_project_files { + my $self = shift; + my ($plugins, $settings, $search) = @_; + + return [ + Test2::Harness::TestFile->new(...), + Test2::Harness::TestFile->new(...), + ..., + ]; + } + +=head1 METHODS + +These are important state methods, as well as utility methods for use in your +subclasses. + +=over 4 + +=item $bool = $finder->multi_project + +True if the C<yath projects> command was used. + +=item $arrayref = $finder->find_files($plugins, $settings) + +This is the main method. This method returns an arrayref of +L<Test2::Harness::TestFile> instances, each one representing a single test to +run. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +B<Note:> In many cases it is better to override C<find_project_files()> in your +subclasses. + +=item $durations = $finder->duration_data + +This will fetch the durations data if any was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +B<Note:> The result is cached, see L<pull_durations()> to refresh the data. + +=item @reasons = $finder->exclude_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This will +return a list of human readible reasons a test file should be excluded. If the +file should not be excluded the list will be empty. + +This is a utility method that verifies the file is not in an exclude +list/pattern. The reasons are provided back in case you need to inform the +user. + +=item $bool = $finder->include_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This is a +convenience method around C<exclude_file()>, it will return true when +C<exclude_file()> returns an empty list. + +=item $arrayref = $finder->find_multi_project_files($plugins, $settings) + +=item $arrayref = $finder->find_project_files($plugins, $settings, $search) + +These do the heavy lifting for C<find_files> + +The default C<find_files()> implementation is this: + + sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + return $self->find_project_files($plugins, $settings, $self->search); + } + +Each one returns an arrayref of L<Test2::Harness::TestFile> instances. + +Note that C<find_multi_project_files()> uses C<find_project_files()> internall, +once per project directory. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +$search is an arrayref of search paths. + +=item $finder->munge_settings($settings, $options) + +A callback that lets you munge settings and options. + +=item $finder->pull_durations + +This will fetch the durations data if ant was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +L<duration_data()> is a cached version of this. This method will refresh the +cache for the other. + +=back + +=head2 FROM SETTINGS + +See L<App::Yath::Options::Finder> for up to date documentation on these. + +=over 4 + +=item $finder->default_search + +=item $finder->default_at_search + +=item $finder->durations + +=item $finder->maybe_durations + +=item $finder->exclude_files + +=item $finder->exclude_patterns + +=item $finder->no_long + +=item $finder->only_long + +=item $finder->search + +=item $finder->extensions + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/IPC.pm b/bad/Test2/Harness/IPC.pm new file mode 100644 index 000000000..4129c9ee1 --- /dev/null +++ b/bad/Test2/Harness/IPC.pm @@ -0,0 +1,520 @@ +package Test2::Harness::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX; + +use Config qw/%Config/; +use Carp qw/croak confess/; +use Time::HiRes qw/sleep time/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use Test2::Harness::IPC::Process; + +BEGIN { + my %SIG_MAP; + my @SIGNAMES = split /\s+/, $Config{sig_name}; + my @SIGNUMS = split /\s+/, $Config{sig_num}; + while (@SIGNAMES) { + $SIG_MAP{shift(@SIGNAMES)} = shift @SIGNUMS; + } + + *SIG_MAP = sub() { \%SIG_MAP }; +} + +use Test2::Harness::Util::HashBase qw{ + <pid + <handlers + <procs + <procs_by_cat + <waiting + <wait_time + <started + <sig_count +}; + +sub init { + my $self = shift; + + $self->{+PID} = $$; + + $self->{+PROCS} //= {}; + $self->{+PROCS_BY_CAT} //= {}; + + $self->{+WAIT_TIME} = 0.02 unless defined $self->{+WAIT_TIME}; + + $self->{+HANDLERS} //= {}; + $self->{+HANDLERS}->{CHLD} //= sub { 1 }; + + $self->{+SIG_COUNT} //= 0; +} + +sub start { + my $self = shift; + + my @caller = caller(1); + + return if $self->{+STARTED}; + $self->{+STARTED} = 1; + + $self->check_for_fork(); + + for my $sig (qw/INT HUP TERM CHLD/) { + croak "Signal '$sig' was already set by something else" + if defined $SIG{$sig} + && $SIG{$sig} ne 'IGNORE' + && $SIG{$sig} ne 'DEFAULT'; + $SIG{$sig} = sub { $self->handle_sig($sig) }; + } +} + +sub stop { + my $self = shift; + + $self->wait(all => 1); + + delete $SIG{$_} for qw/INT HUP TERM CHLD/; + + $self->{+STARTED} = 0; +} + +sub set_sig_handler { + my $self = shift; + my ($sig, $sub) = @_; + $self->{+HANDLERS}->{$sig} = $sub; +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + $self->{+SIG_COUNT}++ unless $sig eq 'CHLD'; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->stop(); + exit(SIG_MAP->{$sig}); +} + +sub killall { + my $self = shift; + my ($sig) = @_; + $sig //= 'TERM'; + + $self->check_for_fork(); + + kill($sig, keys %{$self->{+PROCS}}); +} + +sub check_timeouts {} + +sub check_for_fork { + my $self = shift; + + return 0 if $self->{+PID} == $$; + + $self->{+PROCS} = {}; + $self->{+PROCS_BY_CAT} = {}; + $self->{+WAITING} = {}; + $self->{+PID} = $$; + + return 1; +} + +sub _bring_out_yer_dead { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + # Wait on any/all pids + my $found = 0; + while ((my $pid = waitpid(-1, WNOHANG)) > 0) { + my $exit = $?; + die "waitpid returned pid '$pid', but we are not monitoring that one!" unless $procs->{$pid}; + $found++; + $waiting->{$pid} = [$exit, time()]; + } + + return $found; +} + +sub _check_if_dead_yet { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$waiting) { + next if USE_P_GROUPS && kill(0, -$pid); + $found++; + my $args = delete $waiting->{$pid}; + my $proc = delete $procs->{$pid}; + delete $cat_procs->{$proc->category}->{$pid}; + $self->set_proc_exit($proc, @$args); + } + + return $found; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, @args) = @_; + $proc->set_exit($self, @args); +} + +sub _ex_parrots { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$procs) { + next if $waiting->{$pid}; + next if kill(0, $pid); + $found++; + warn "Process $pid vanished!"; + $waiting->{$pid} = [-1, time()]; + } + + return $found; +} + +sub wait { + my $self = shift; + my %params = @_; + + $self->check_for_fork(); + + my $sig_count = $self->{+SIG_COUNT}; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + return 0 unless keys(%$procs) || keys(%$waiting); + + my $cat_total = $params{cat} ? keys %{$cat_procs->{$params{cat}}} : 0; + + my $start = time; + + my $count = 0; + my $found = 0; + while (1) { + $self->check_timeouts; + + $found += $self->_bring_out_yer_dead(); + $found += $self->_check_if_dead_yet(); + + return $found if $self->_wait_done($found, $start, \%params); + + if (my $cat = $params{cat}) { + my $cur_total = keys %{$cat_procs->{$cat}}; + return 0 unless $cur_total; + my $delta = $cat_total - $cur_total; + return $delta if $delta; + } + + # This is expensive, so only do it if we are gonna end up waiting + # anyway If we do find anything here do not bother waiting. + next if $self->_ex_parrots(); + + # Break the loop if we had a signal come in since starting + last if $self->{+SIG_COUNT} > $sig_count; + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "We escaped the wait cycle"; + return $found; +} + +sub _wait_done { + my $self = shift; + my ($found, $start, $params) = @_; + + my $all = keys(%{$self->{+PROCS}}); + return 1 unless $all; + + return 1 if $params->{timeout} && time - $start >= $params->{timeout}; + + return 0 if $all && $params->{all}; + + return 0 if $params->{all_cat} && keys %{$self->{+PROCS_BY_CAT}->{$params->{all_cat}}}; + + return 0 if $params->{block} && !$found; + + # This gets validated outside this loop + return 0 if $params->{cat}; + + return 1; +} + +sub watch_pid { + my $self = shift; + my ($pid) = @_; + + my $proc = Test2::Harness::IPC::Process->new(pid => $pid); + + return $self->watch($proc); +} + +sub watch { + my $self = shift; + my ($proc) = @_; + + $self->check_for_fork(); + + my $pid = $proc->pid or confess "Process has no pid"; + $pid = abs($pid) if USE_P_GROUPS; + + croak "Already watching pid $pid" if exists $self->{+PROCS}->{$pid}; + + $self->{+PROCS}->{$pid} = $proc; + $self->{+PROCS_BY_CAT}->{$proc->category}->{$pid} = $proc; +} + +sub spawn { + my $self = shift; + my ($proc, $params); + if (@_ == 1) { + $proc = shift(@_); + $params = $proc->spawn_params; + } + else { + $params = {@_}; + my $class = $params->{process_class} // 'Test2::Harness::IPC::Process'; + $proc = $class->new(); + } + + croak "No 'command' specified" unless $params->{command}; + + my $caller1 = [caller()]; + my $caller2 = [caller(1)]; + + my $env = $params->{env_vars} // {}; + + $self->check_for_fork(); + + my $pid = run_cmd(env => $env, caller1 => $caller1, caller2 => $caller2, %$params); + $proc->set_pid($pid); + + $self->watch($proc); + return $proc; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC - Base class for modules that control child processes. + +=head1 DESCRIPTION + +This module is the base class for all parts of L<Test2::Harness> that have to +do process management. + +=head1 ATTRIBUTES + +=over 4 + +=item $pid = $ipc->pid + +The root PID of the IPC object. + +=item $hashref = $ipc->handlers + +Custom signal handlers specific to the IPC object. + +=item $hashref = $ipc->procs + +Hashref of C<< $pid => $proc >> where $proc is an instance of +L<Test2::Harness::IPC::Proc>. + +=item $hashref = $ipc->procs_by_cat + +Hashref of C<< $category => { $pid => $proc } >>. + +=item $hashref = $ipc->waiting + +Hashref of processes that have finished, but have not been handled yet. + +This is an implementation detail you should not rely on. + +=item $float = $ipc->wait_time + +How long to sleep between loops when in a wait cycle. + +=item $bool = $ipc->started + +True if the IPC process has started. + +=item $ipc->sig_count + +Implementation detail, used to break wait loops when signals are received. + +=back + +=head1 METHODS + +=over 4 + +=item $ipc->start + +Start the IPC management (Insert signal handlers). + +=item $ipc->stop + +Stop the IPC management (Remove signal handlers). + +=item $ipc->set_sig_handler($sig, sub { ... }) + +Set a custom signal handler. This is a safer version of +C<< local %SIG{$sig} >> for use with IPC. + +The callback will get exactly one argument, the name of the signal that was +recieved. + +=item $ipc->handle_sig($sig) + +Handle the specified signal. Will cause process exit if the signal has no +handler. + +=item $ipc->killall() + +=item $ipc->killall($sig) + +Kill all tracked child process with the given signal. C<TERM> is used if no +signal is specified. + +This will not wait on the processes, you must call C<< $ipc->wait() >>. + +=item $ipc->check_timeouts + +This is a no-op on the IPC base class. This is called every loop of +C<< $ipc->wait >>. If you subclass the IPC class you can fill this in to make +processes timeout if needed. + +=item $ipc->check_for_fork + +This is used a lot internally to check if this is a forked process. If this is +a forked process the IPC object is completely reset with no remaining internal +state (except signal handlers). + +=item $ipc->set_proc_exit($proc, @args) + +Calls C<< $proc->set_exit(@args) >>. This is called by C<< $ipc->wait >>. You +can override it to add custom tasks when a process exits. + +=item $int = $ipc->wait() + +=item $int = $ipc->wait(%params) + +Wait on processes, return the number found. + +Default is non-blocking. + +Options: + +=over 4 + +=item timeout => $float + +If a blocking paremeter is provided this can be used to break the wait after a +timeout. L<Time::HiRes> is used, so timeout is in seconds with decimals. + +=item all => $bool + +Block until B<ALL> processes are done. + +=item cat => $category + +Block until at least 1 process from the category is complete. + +=item all_cat => $category + +Block until B<ALL> processes from the category are complete. + +=item block => $bool + +Block until at least 1 process is complete. + +=back + +=item $ipc->watch($proc) + +Add a process to be monitored. + +=item $proc = $ipc->spawn($proc) + +=item $proc = $ipc->spawn(%params) + +In the first form $proc is an instance of L<Test2::Harness::IPC::Proc> that +provides C<spawn_params()>. + +In the second form the following params are allowed: + +Anything supported by C<run_cmd()> in L<Test2::Harness::Util::IPC>. + +=over 4 + +=item process_class => $CLASS + +Default is L<Test2::Harness::IPC::Process>. + +=item command => $command + +Program command to call. This is required. + +=item env_vars => { ... } + +Specify custom environment variables for the new process. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/IPC/Model.pm b/bad/Test2/Harness/IPC/Model.pm new file mode 100644 index 000000000..c42d6a2d5 --- /dev/null +++ b/bad/Test2/Harness/IPC/Model.pm @@ -0,0 +1,48 @@ +package Test2::Harness::IPC::Model; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util::HashBase qw{ + <state <pid <run_id +}; + +sub init { + my $self = shift; + + $self->{+PID} //= $$; + croak "'state' is required" unless $self->{+STATE}; + croak "'run_id' is required" unless $self->{+RUN_ID}; +} + +sub establish_interactive_stdin { + my $self = shift; + + my $fh; + + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + open($fh, '<', $fifo) or die "Could not open fifo '$fifo': $!"; + } + elsif (-t STDIN) { + $fh = \*STDIN; + } + else { + confess "No human input source is available"; + } + + return $fh; +} + +sub get_test_stdout_pair { croak(blessed($_[0]) . '->get_test_stdout_pair() is not implemented') } +sub get_test_stderr_pair { croak(blessed($_[0]) . '->get_test_stderr_pair() is not implemented') } +sub get_test_events_pair { croak(blessed($_[0]) . '->get_test_events_pair() is not implemented') } +sub add_renderer { croak(blessed($_[0]) . '->add_renderer() is not implemented') } +sub render_event { croak(blessed($_[0]) . '->render_event() is not implemented') } + +sub finish {} + +1; diff --git a/bad/Test2/Harness/IPC/Model/AtomicPipe.pm b/bad/Test2/Harness/IPC/Model/AtomicPipe.pm new file mode 100644 index 000000000..0eb71c011 --- /dev/null +++ b/bad/Test2/Harness/IPC/Model/AtomicPipe.pm @@ -0,0 +1,198 @@ +package Test2::Harness::IPC::Model::AtomicPipe; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use POSIX qw/mkfifo/; +use File::Path qw/make_path/; + +use File::Spec; +use Atomic::Pipe; + +use Test2::Util qw/get_tid/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +pair_cache + +renderer_writers +}; + +sub _get_mixed_pair { + my $self = shift; + + my ($r, $w) = Atomic::Pipe->pair(mixed_data_mode => 1); + + $r->resize($r->max_size); + $w->resize($w->max_size); + $w->wh->autoflush(1); + + my %out; + + my (@lines, @data); + my $read = sub { + if ($w) { + $w->close(); + $w = undef; + delete $out{write_ap}; + } + + while (1) { + my ($type, $val) = $r->get_line_burst_or_data; + last unless $type; + + if ($type eq 'message') { + push @data => decode_json($val); + } + elsif ($type eq 'line') { + push @lines => $val; + } + else { + die "Invalid type '$type'"; + } + } + }; + + my $read_line = sub { $read->(); my @out = @lines; @lines = (); return @out }; + my $read_data = sub { $read->(); my @out = @data; @data = (); return @out }; + + %out = ( + read_line => $read_line, + read_data => $read_data, + read_ap => $r, + write_ap => $w, + ); + + return \%out; +} + +sub get_test_stdout_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + return ($bits->{read_line}, $bits->{write_ap}->wh()); +} + +sub get_test_stderr_pair { + my $self = shift; + my ($r, $w) = Atomic::Pipe->pair; + $r->resize($r->max_size); + my $rh = $r->rh; + $rh->blocking(0); + $w->resize($w->max_size); + $w->wh->autoflush(1); + return (sub { <$rh> }, $w->wh()); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + my $writer_sub = sub { + if ($bits->{read_ap}) { + $bits->{read_ap}->close(); + delete $bits->{read_ap}; + delete $bits->{read_line}; + delete $bits->{read_data}; + } + + $bits->{write_ap}->write_message(encode_json($_)) for @_; + }; + + return ($bits->{read_data}, $writer_sub); +} + +sub add_renderer { + my $self = shift; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, 'renderers'); + make_path($path) unless -d $path; + + # Create file for fifo + my $id = gen_uuid(); + my $file = File::Spec->catfile($path, "${id}.fifo"); + + # make fifo + mkfifo($file, 0700) or die "Failed to create fifo"; + + my $r = Atomic::Pipe->read_fifo($file); + $r->resize($r->max_size); + $r->blocking(0); + + # add the fifo to state for future writers + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + my $files = $data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} //= []; + push @$files => $file; + }); + + # return a sub to read the fifo + return sub { + my @out; + while (my $msg = $r->read_message) { + push @out => decode_json($msg); + } + return @out; + }; +} + +sub renderer_writers { + my $self = shift; + + if (my $have = $self->{+RENDERER_WRITERS}) { + return @{$have->{list} //= []} if $have->{pid} == $$ && $have->{tid} == get_tid(); + delete $self->{+RENDERER_WRITERS}; + delete $_->{out_buffer} for @{$have->{list} // []}; + } + + my @list; + for my $ap (@{$self->{+STATE}->data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} // []}) { + my $w = Atomic::Pipe->write_fifo($ap); + $w->resize($w->max_size); + push @list => $w; + } + + $self->{+RENDERER_WRITERS} = { + pid => $$, + tid => get_tid(), + list => \@list, + }; + + return @list; +} + +sub render_event { + my $self = shift; + my ($e) = @_; + + my $json = encode_json($e); + + $_->write_message($json) for $self->renderer_writers; +} + +sub finish { + my $self = shift; + # Blocking flush on all/any renderer handles + + # First flush any that can be flushed without a wait + $_->flush(blocking => 0) for $self->renderer_writers; + + # Terminate the output + $self->render_event(undef); + + # Now we wait and flush all. + for my $ap ($self->renderer_writers) { + $ap->flush(blocking => 1); + $ap->close(); + } +} + +1; diff --git a/bad/Test2/Harness/IPC/Model/FilePipeHybrid.pm b/bad/Test2/Harness/IPC/Model/FilePipeHybrid.pm new file mode 100644 index 000000000..7f8870900 --- /dev/null +++ b/bad/Test2/Harness/IPC/Model/FilePipeHybrid.pm @@ -0,0 +1,56 @@ +package Test2::Harness::IPC::Model::FilePipeHybrid; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use Test2::Harness::IPC::Model::Files; +use Test2::Harness::IPC::Model::AtomicPipe; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + -files + -pipes +}; + +sub init { + my $self = shift; + + $self->{+FILES} //= Test2::Harness::IPC::Model::Files->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); + $self->{+PIPES} //= Test2::Harness::IPC::Model::AtomicPipe->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); +} + +sub get_test_stdout_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stdout_pair(@_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stderr_pair(@_); +} + +sub get_test_events_pair { + my $self = shift; + return $self->{+PIPES}->get_test_events_pair(@_); +} + +sub add_renderer { + my $self = shift; + $self->{+FILES}->add_renderer(@_); +} + +sub render_event { + my $self = shift; + $self->{+FILES}->render_event(@_); +} + +sub finish { + my $self = shift; + $self->{+FILES}->finish(@_); + $self->{+PIPES}->finish(@_); +} + +1; diff --git a/bad/Test2/Harness/IPC/Model/Files.pm b/bad/Test2/Harness/IPC/Model/Files.pm new file mode 100644 index 000000000..9851cac3f --- /dev/null +++ b/bad/Test2/Harness/IPC/Model/Files.pm @@ -0,0 +1,149 @@ +package Test2::Harness::IPC::Model::Files; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use File::Spec; +use File::Path qw/make_path/; + +use Test2::Util qw/get_tid ipc_separator/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Stream; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +render_writer +}; + +sub get_test_stdout_pair { + my $self = shift; + return $self->_get_std_pair(STDOUT => @_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->_get_std_pair(STDERR => @_); +} + +sub _get_std_pair { + my $self = shift; + my ($fname, $job_id, $job_try) = @_; + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, $job_id, $job_try); + + make_path($path) unless -d $path; + + my $file = File::Spec->catfile($path, $fname); + + open(my $wh, '>>', $file) or die "Could not open '$file' for writing: $!"; + + my $rs; + my $read_sub = sub { + $rs //= Test2::Harness::Util::File::Stream->new(name => $file); + $rs->poll(); + }; + + return ($read_sub, $wh); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $reader_sub = $self->_generate_reader(event_files => $job_id, $job_try); + my $writer_sub = $self->_generate_writer(event_files => $job_id, $job_try); + + return ($reader_sub, $writer_sub); +} + +sub add_renderer { + my $self = shift; + return $self->_generate_reader('render_files'); +} + +sub render_event { + my $self = shift; + my ($e) = @_; + my $writer = $self->{+RENDER_WRITER} //= $self->_generate_writer('render_files'); + $writer->($e); +} + +sub _generate_writer { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, $stream, $file) = (0, 0); + my $writer_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + $file = File::Spec->catfile($path, join(ipc_separator(), time, $pid, $tid) . ".jsonl"); + $stream = Test2::Harness::Util::File::JSONL->new(name => $file); + $self->{+STATE}->transaction(w => sub { + my ($state) = @_; + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + push @$files => $file; + }); + } + + $stream->write($_) for @_; + }; +} + +sub _generate_reader { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, %streams) = (0, 0); + my $reader_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + + # Clear stream cache on new proc/thread + %streams = (); + } + + my @events; + + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + for my $file (@$files) { + my $stream = $streams{$file} //= Test2::Harness::Util::File::JSONL->new(name => $file); + push @events => $stream->poll(); + } + + return @events; + }; + + return $reader_sub; +} + +sub _get_file_list { + my $self = shift; + my @path = @_; + my $last = pop @path; + + my $data = $self->{+STATE}->data->ipc_model; + $data = $data->{$_} //= {} for @path; + $data = $data->{$last} //= []; + return $data; +} + +sub finish { + my $self = shift; + $self->render_event(undef); +} + +1; diff --git a/bad/Test2/Harness/IPC/Process.pm b/bad/Test2/Harness/IPC/Process.pm new file mode 100644 index 000000000..d15e472be --- /dev/null +++ b/bad/Test2/Harness/IPC/Process.pm @@ -0,0 +1,134 @@ +package Test2::Harness::IPC::Process; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <exit <exit_time + <pid + +category +}; + +sub category { $_[0]->{+CATEGORY} //= 'default' } + +sub set_pid { + my $self = shift; + my ($pid) = @_; + + croak "pid has already been set" if defined $self->{+PID}; + + $self->{+PID} = $pid; +} + +sub set_exit { + my $self = shift; + my ($ipc, $exit, $time) = @_; + + croak "exit has already been set" if defined $self->{+EXIT}; + + $self->{+EXIT} = $exit; + $self->{+EXIT_TIME} = $time; +} + +sub spawn_params { + my $self = shift; + my $class = ref($self) || $self; + + croak "Process class '$class' does not implement 'spawn_params()'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::Process - Base class for processes controlled by +Test2::Harness::IPC. + +=head1 DESCRIPTION + +All processes controlled by L<Test2::Harness::IPC> should subclass this one. + +=head1 ATTRIBUTES + +=over 4 + +=item $int = $proc->exit + +Exit value, if set. Otherwise C<undef>. + +=item $stamp = $proc->exit_time + +Timestamp of the process exit, if set, otherwise C<undef>. + +=item $pid = $proc->pid + +Pid of the process, if it has been started. + +=item $cat = $proc->category + +Set at construction, C<'default'> if not provided. + +=back + +=head1 METHODS + +=over 4 + +=item $opt->set_pid($pid) + +Set the process id. + +=item $opt->set_exit($ipc, $exit, $time) + +Set the process as complete. $exit should be the exit value. $time should be a +timestamp. $ipc is an instance of L<Test2::Harness::IPC>. + +=item $hashref = $opt->spawn_params() + +Used when spawning the process, args go to C<run_cmd()> from +L<Test2::Harness::Util::IPC>. + +The base class throws an exception if this method is called. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/IPC/SharedState.pm b/bad/Test2/Harness/IPC/SharedState.pm new file mode 100644 index 000000000..7c55b8690 --- /dev/null +++ b/bad/Test2/Harness/IPC/SharedState.pm @@ -0,0 +1,330 @@ +package Test2::Harness::IPC::SharedState; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Test2::Harness::Util::File::JSON; +use Scalar::Util qw/weaken blessed/; +use Time::HiRes qw/time stat/; +use Carp qw/croak confess/; +use Fcntl qw/:flock/; +use Errno qw/EINTR EAGAIN ESRCH/; + +use Test2::Harness::Util::HashBase qw{ + <state_file <state_fh <state_umask + + access_id access_pid access_meta + <timeout + + +transaction + + <registered <unregistered +}; + +use constant LOCAL => 'local'; +use constant ACCESS => 'access'; + +sub state_class {} + +sub init { + my $self = shift; + + croak "'state_file' is a required attribute" unless $self->{+STATE_FILE}; + + $self->{+TIMEOUT} //= 300; # Timeout runs if they do not update at least every 5 min + $self->{+STATE_UMASK} //= 0007; +} + +sub state { shift->transaction('r') } +sub data { shift->transaction('r') } + +sub init_state { + my $self = shift; + return {timeout => $self->{+TIMEOUT}}; +} + +sub transaction { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $mode //= 'r'; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + croak "mode must be 'w', 'rw', 'r', or 'ro', got '$mode'" unless $write || $read; + + if ($write) { + confess "Write mode requires a 'access_id'" unless $self->access_id; + my $pid = $self->access_pid or confess "Write mode requires a 'access_pid'"; + confess "Access PID mismatch ($pid vs $$)" unless $$ == $pid; + } + + my ($lock, $state, $local, $new); + if ($state = $self->{+TRANSACTION}) { + $new = 0; + $local = $state->{+LOCAL}; + + confess "Attempted a 'write' transaction inside of a read-only transaction" + if $write && !$local->{write}; + } + else { + $new = 1; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $lockf = "$self->{+STATE_FILE}.LOCK"; + + open($lock, '>>', $lockf) or die "Could not open lock file '$lockf': $!"; + while (1) { + last if flock($lock, $write ? LOCK_EX : LOCK_SH); + next if $! == EINTR || $! == EAGAIN; + warn "Could not get lock: $!"; + } + + $state = $self->_read_state(); + 1; + }; + my $err = $@; + umask($oldmask); + die $err unless $ok; + + $local = $state->{+LOCAL} = { + lock => $lock, + mode => $mode, + write => $write, + stack => [{cb => $cb, args => \@args}], + }; + + weaken($state->{+LOCAL}->{lock}); + } + + local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => \@args}]) + if $self->{+TRANSACTION}; + + local $self->{+TRANSACTION} = $state; + + if ($new) { + if ($write) { + if ($self->registered) { + $self->_verify_registration($state); + } + else { + $self->_update_registration($state); + } + } + $self->_clear_old_registrations($state); + } + + my $out; + my $ok = eval { $out = $cb ? $self->$cb($state, @args) : $state; 1 }; + my $err = $@; + + if ($ok && $write && $new) { + $self->_clear_old_registrations($state); + $self->_update_registration($state) unless $self->{+UNREGISTERED}; + $self->_write_state($state); + } + + if ($lock) { + flock($lock, LOCK_UN) or die "Could not release lock: $!"; + } + + die $err unless $ok; + + return $out; +} + +sub _read_state { + my $self = shift; + + return $self->init_state unless -e $self->{+STATE_FILE}; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + + my ($ok, $err, $state); + for (1 .. 5) { + $ok = eval { $state = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.2; + } + + warn "Corrupted state? Resetting state to initial. Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + $state ||= $self->init_state; + + $self->sync_from_state($state); + + my $class = $self->state_class or return $state; + return $state if blessed($state); + return bless($state, $class); +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->{+TIMEOUT} = $state->{timeout}; +} + +sub _write_state { + my $self = shift; + my ($state) = @_; + + my $state_copy = {%$state}; + + my $local = delete $state_copy->{+LOCAL}; + + confess "Attempted write with no lock" unless $local->{lock}; + confess "Attempted write with a read-only lock" unless $local->{write}; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + $file->rewrite($state_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +sub update_registration { $_[0]->transaction(rw => '_update_registration') } +sub remove_registration { $_[0]->transaction(rw => '_update_registration', remove => 1) } + +sub _update_registration { + my $self = shift; + my ($state, %params) = @_; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id} //= { + %{$self->{+ACCESS_META} // {}}, + access_id => $access_id, + access_pid => $self->access_pid, + user => $ENV{USER}, + added => time, + }; + + # Update our last checkin time + $entry->{seen} = time; + + $self->{+REGISTERED} = $$; + + return $state unless $params{remove}; + + $self->{+UNREGISTERED} = 1; + $entry->{remove} = 1; + + return $state; +} + +sub _verify_registration { + my $self = shift; + my ($state) = @_; + + return unless $self->registered; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id}; + + # Do not allow for a new expiration. If the state has already expired us we will see it. + $entry->{seen} = time if $entry; + + return unless $self->{+UNREGISTERED} //= $self->_entry_expired($entry); + + confess "Shared state registration expired"; +} + +sub _entry_expired { + my $self = shift; + my ($entry) = @_; + + return 1 unless $entry; + return 1 if $entry->{remove}; + + if (my $pid = $entry->{+ACCESS_PID}) { + my $ret = kill(0, $pid); + my $err = $!; + return 1 if $ret == 0 && $! == ESRCH; + } + + my $seen = $entry->{seen} or return 1; + my $delta = time - $seen; + + return 1 if $self->{+TIMEOUT} && $delta > $self->{+TIMEOUT}; + + return 0; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $access = $state->{+ACCESS} //= {}; + + my (%removed); + for my $entry (values %$access) { + $entry->{remove} = 1 if $self->_entry_expired($entry); + next unless $entry->{remove}; + + my $access_id = $entry->{access_id}; + + $self->{+UNREGISTERED} = 1 if $access_id eq $self->access_id; + + delete $access->{$access_id}; + + $removed{$access_id}++; + } + + return [keys %removed]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::SharedState - IPC Shared State + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib/Test2/Harness/Log.pm b/bad/Test2/Harness/Log.pm similarity index 100% rename from lib/Test2/Harness/Log.pm rename to bad/Test2/Harness/Log.pm diff --git a/lib/Test2/Harness/Log/CoverageAggregator.pm b/bad/Test2/Harness/Log/CoverageAggregator.pm similarity index 100% rename from lib/Test2/Harness/Log/CoverageAggregator.pm rename to bad/Test2/Harness/Log/CoverageAggregator.pm diff --git a/lib/Test2/Harness/Log/CoverageAggregator/ByRun.pm b/bad/Test2/Harness/Log/CoverageAggregator/ByRun.pm similarity index 100% rename from lib/Test2/Harness/Log/CoverageAggregator/ByRun.pm rename to bad/Test2/Harness/Log/CoverageAggregator/ByRun.pm diff --git a/lib/Test2/Harness/Log/CoverageAggregator/ByTest.pm b/bad/Test2/Harness/Log/CoverageAggregator/ByTest.pm similarity index 100% rename from lib/Test2/Harness/Log/CoverageAggregator/ByTest.pm rename to bad/Test2/Harness/Log/CoverageAggregator/ByTest.pm diff --git a/lib/Test2/Harness/Plugin.pm b/bad/Test2/Harness/Plugin.pm similarity index 100% rename from lib/Test2/Harness/Plugin.pm rename to bad/Test2/Harness/Plugin.pm diff --git a/bad/Test2/Harness/Renderer.pm b/bad/Test2/Harness/Renderer.pm new file mode 100644 index 000000000..4442d0e7f --- /dev/null +++ b/bad/Test2/Harness/Renderer.pm @@ -0,0 +1,154 @@ +package Test2::Harness::Renderer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw/-settings -verbose -progress -color -command_class/; + +sub render_event { croak "$_[0] forgot to override 'render_event()'" } + +sub step {} + +sub finish { } + +sub signal { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer - Base class for Test2::Harness event renderers. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be changed. + +=over 4 + +=item $settings = $renderer->settings + +Get the L<Test2::Harness::Settings> reference. + +=item $int = $renderer->verbose + +Get the verbosity level. + +=item $bool = $renderer->progress + +True if progress indicators should be shown. + +=item $bool = $renderer->color + +True if color should be used. + +=back + +=head1 METHODS + +=over 4 + +=item $renderer->render_event($event) + +Called for every event. Return is ignored. + +=item $renderer->finish(%ARGS) + +Called once after testing is done. + +C<%ARGS>: + +=item $renderer->signal($signal) + +Called when the rendering process receives a signal. This is your chance to do +any cleanup or report the signal. This is not an event, you can ignore it. Do +not exit or throw any exceptions here please. + +=over 4 + +=item settings => $settings + +Get the L<Test2::Harness::Settings> reference. + +=item pass => $bool + +True if tests passed. + +=item tests_seen => $int + +Number of test files seen. + +=item asserts_seen => $int + +Number of assertions made. + +=item final_data => $final_data + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Renderer/Formatter.pm b/bad/Test2/Harness/Renderer/Formatter.pm new file mode 100644 index 000000000..45f04f0ff --- /dev/null +++ b/bad/Test2/Harness/Renderer/Formatter.pm @@ -0,0 +1,215 @@ +package Test2::Harness::Renderer::Formatter; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Storable qw/dclone/; + +use Test2::Harness::Util qw/fqmod mod2file/; +use Test2::Harness::Util::JSON qw/encode_pretty_json/; + +BEGIN { require Test2::Harness::Renderer; our @ISA = ('Test2::Harness::Renderer') } +use Test2::Harness::Util::HashBase qw{ + -io -io_err + -formatter + -show_run_info + -show_job_info + -show_job_launch + -show_job_end + -do_step + -interactive +}; + +sub init { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + + my $formatter = $self->{+FORMATTER} //= 'Test2'; + my $f_class = fqmod('Test2::Formatter', $formatter); + my $f_file = mod2file($f_class); + require $f_file; + + my $io = $self->{+IO} || $self->{output} || \*STDOUT; + unless (ref $io) { + open(my $fh, '>', $io) or die "Could not open file '$io' for writing: $!"; + $self->{+IO} = $fh; + } + + my $io_err = $self->{+IO_ERR} || $self->{output} || \*STDERR; + unless (ref $io_err) { + open(my $fh, '>', $io_err) or die "Could not open file '$io_err' for writing: $!"; + $self->{+IO_ERR} = $fh; + } + + $self->{+INTERACTIVE} = 1 if $settings->debug->interactive; + $self->{+INTERACTIVE} //= 1 if $ENV{YATH_INTERACTIVE}; + + $self->{+FORMATTER} = $f_class->new( + io => $self->{+IO}, + progress => $self->{+PROGRESS}, + handles => [$self->{+IO}, $self->{+IO_ERR}, $self->{+IO}], + verbose => $settings->display->verbose, + color => $settings->display->color, + no_wrap => $settings->display->no_wrap, + interactive => $self->{+INTERACTIVE}, + is_persistent => $self->{+COMMAND_CLASS}->group eq 'persist' ? 1 : 0, + ); + + $self->{+DO_STEP} = $self->{+FORMATTER}->can('step') ? 1 : 0; + + $self->{+SHOW_JOB_END} = 1 unless defined $self->{+SHOW_JOB_END}; +} + +sub step { + my $self = shift; + return unless $self->{+DO_STEP}; + $self->{+FORMATTER}->step; +} + +sub render_event { + my $self = shift; + my ($event) = @_; + + # We modify the event, which would be bad if there were multiple renderers, + # so we deep clone it. + $event = dclone($event); + + my $settings = $self->{+SETTINGS}; + + my $f = $event->{facet_data}; # Optimization + + $f->{harness} = {%$event}; + delete $f->{harness}->{facet_data}; + + if ($self->{+SHOW_RUN_INFO} && $f->{harness_run}) { + my $run = $f->{harness_run}; + + push @{$f->{info}} => { + tag => 'RUN INFO', + details => encode_pretty_json($run), + }; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + + $f->{harness}->{job_id} ||= $job->{job_id}; + + if ($self->{+SHOW_JOB_LAUNCH}) { + push @{$f->{info}} => { + tag => $f->{harness_job_launch}->{retry} ? 'RETRY' : 'LAUNCH', + debug => 0, + important => 1, + details => File::Spec->abs2rel($job->{file}), + }; + } + + if ($self->{+SHOW_JOB_INFO}) { + push @{$f->{info}} => { + tag => 'JOB INFO', + details => encode_pretty_json($job), + }; + } + } + + if ($f->{harness_job_end}) { + my $job = $f->{harness_job}; + my $skip = $f->{harness_job_end}->{skip}; + my $fail = $f->{harness_job_end}->{fail}; + my $file = $f->{harness_job_end}->{file}; + my $retry = $f->{harness_job_end}->{retry}; + + my $job_id = $f->{harness}->{job_id} ||= $job->{job_id}; + + # Make the times important if they were requested + if ($settings->display->show_times && $f->{info}) { + for my $info (@{$f->{info}}) { + next unless $info->{tag} eq 'TIME'; + $info->{important} = 1; + } + } + + if ($self->{+SHOW_JOB_END}) { + my $name = File::Spec->abs2rel($file); + $name .= " - $skip" if $skip; + + my $tag = 'PASSED'; + $tag = 'SKIPPED' if $skip; + $tag = 'FAILED' if $fail; + $tag = 'TO RETRY' if $retry; + + unshift @{$f->{info}} => { + tag => $tag, + debug => $fail, + important => 1, + details => $name, + }; + } + } + + my $num = $f->{assert} && $f->{assert}->{number} ? $f->{assert}->{number} : undef; + + $self->{+FORMATTER}->write($event, $num, $f); +} + +sub finish { + my $self = shift; + $self->{+FORMATTER}->finalize(); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer::Formatter - Renderer that uses any Test2::Formatter +for rendering. + +=head1 DESCRIPTION + +This renderer simply acts as a communication layer between the harness and any +Test2 formatter that you wish to use to display results. Not all formatters +will produce useful output for harness events. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Run.pm b/bad/Test2/Harness/Run.pm new file mode 100644 index 000000000..06b13075d --- /dev/null +++ b/bad/Test2/Harness/Run.pm @@ -0,0 +1,182 @@ +package Test2::Harness::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <run_id + + <env_vars <author_testing <unsafe_inc + + <links + + <event_uuids + <use_stream + <mem_usage + <io_events + + <dbi_profiling + + <input <input_file <test_args + + <load <load_import + + <fields <meta + + <retry <retry_isolated +}; + +sub init { + my $self = shift; + + croak "run_id is required" + unless $self->{+RUN_ID}; +} + +sub run_dir { + my $self = shift; + my ($workdir) = @_; + return File::Spec->catfile($workdir, $self->{+RUN_ID}); +} + +sub TO_JSON { +{ %{$_[0]} } } + +sub queue_item { + my $self = shift; + my ($plugins) = @_; + + croak "a plugins arrayref is required" unless $plugins; + + my $out = {%$self}; + + my $meta = $out->{+META} //= {}; + my $fields = $out->{+FIELDS} //= []; + for my $p (@$plugins) { + $p->inject_run_data(meta => $meta, fields => $fields, run => $self); + } + + return $out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Run - Representation of a set of tests to run, and their +options. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be modified. + +See L<App::Yath::Options::Run> for more documentation on these. + +=head2 FROM OPTIONS + +=over 4 + +=item $bool = $run->author_testing + +=item $hashref = $run->env_vars + +=item $bool = $run->event_uuids + +=item $arrayref = $run->fields + +=item $string = $run->input + +=item $path = $run->input_file + +=item $bool = $run->io_events + +=item $arrayref = $run->links + +=item $arrayref = $run->load + +=item $hashref = $run->load_import + +=item $bool = $run->mem_usage + +=item $int = $run->retry + +=item $bool = $run->retry_isolated + +=item $string = $run->run_id + +=item $arrayref = $run->test_args + +=item $bool = $run->unsafe_inc + +=item $bool = $run->use_stream + +=back + +=head2 OTHER + +=over 4 + +=item $hashref = $run->meta + +meta-data plugins may have attached. + +=back + +=head1 METHODS + +=over 4 + +=item $path = $run->run_dir($workdir) + +Returns the path C<"$workdir/$run_id">. + +=item $hashref = $run->queue_item(\@PLUGINS) + +Gets the queue item that represents this object. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner.pm b/bad/Test2/Harness/Runner.pm new file mode 100644 index 000000000..073e47aec --- /dev/null +++ b/bad/Test2/Harness/Runner.pm @@ -0,0 +1,681 @@ +package Test2::Harness::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use POSIX qw/:sys_wait_h/; +use Long::Jump qw/setjump longjump/; +use Time::HiRes qw/sleep time/; +use Scope::Guard; + +use Test2::Harness::Util qw/clean_path file2mod mod2file open_file parse_exit write_file_atomic process_includes chmod_tmp write_file/; +use Test2::Harness::Util::JSON qw/encode_json/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run(); +use Test2::Harness::Runner::Job(); +use Test2::Harness::Runner::Spawn(); +use Test2::Harness::Runner::Preload(); +use Test2::Harness::Runner::Preloader(); +use Test2::Harness::Runner::Preloader::Stage(); +use Test2::Harness::Runner::DepTracer(); + +use parent 'Test2::Harness::IPC'; +use Test2::Harness::Util::HashBase( + # Fields from settings + qw{ + <job_count <slots_per_job + + <includes <tlib <lib <blib + <unsafe_inc + + <use_fork <preloads <preload_threshold <switches + <restrict_reload + + <cover + + <event_timeout <post_exit_timeout + + <nytprof + + <reload + }, + # From Construction + qw{ + <dir <settings <fork_job_callback <fork_spawn_callback <respawn_runner_callback <monitor_preloads + <jobs_todo <dump_depmap <state + }, + # Other + qw { + +preloader + <no_preload_wait + +scheduler + + <stage + <signal + + +last_timeout_check + +dispatch_lock_file + +can_stage + <tmp_dir + + <rootpid + }, +); + +sub job_class { 'Test2::Harness::Runner::Job' } + +our $RUNNER_PID; + +sub init { + my $self = shift; + + $self->{+ROOTPID} = $$; + $RUNNER_PID = $$; + + my $state = $self->{+STATE} or croak "'state' is a required attribute"; + + $self->{+SETTINGS} //= $state->settings; + $self->{+DIR} //= $state->workdir; + my $dir = clean_path($self->{+DIR}); + + croak "'$dir' is not a valid directory" + unless -d $dir; + + $self->{+DIR} = $dir; + + $self->{+HANDLERS}->{HUP} = sub { + my $sig = shift; + print "$$ $0 ($self->{+STAGE}) Runner caught SIG$sig, reloading...\n"; + $self->{+SIGNAL} = $sig; + }; + + my $tmp_dir = File::Spec->catdir($self->{+DIR}, 'tmp'); + unless (-d $tmp_dir) { + mkdir($tmp_dir) or die "Could not create temp dir: $!"; + chmod_tmp($tmp_dir); + } + $self->{+TMP_DIR} = $tmp_dir; + + $self->SUPER::init(); +} + +sub scheduler { + my $self = shift; + $self->{+SCHEDULER} //= $self->state->scheduler( + preloader => $self->preloader, + ); +} + +sub preloader { + my $self = shift; + + $self->{+PRELOADER} //= Test2::Harness::Runner::Preloader->new( + dir => $self->{+DIR}, + preloads => $self->preloads, + monitor => $self->{+MONITOR_PRELOADS}, + restrict_reload => $self->{+RESTRICT_RELOAD}, + dump_depmap => $self->{+DUMP_DEPMAP}, + reload => $self->{+RELOAD}, + state => $self->{+STATE}, + + below_threshold => $self->{+PRELOAD_THRESHOLD} && $self->{+JOBS_TODO} && $self->{+PRELOAD_THRESHOLD} > $self->{+JOBS_TODO}) ? 1 : 0, + ); +} + +sub check_timeouts { + my $self = shift; + + return unless $self->settings->runner->use_timeout; + + my $now = time; + + # Check only once per second, that is as granular as we get. Also the check is not cheep. + return if $self->{+LAST_TIMEOUT_CHECK} && $now < (1 + $self->{+LAST_TIMEOUT_CHECK}); + + for my $pid (keys %{$self->{+PROCS}}) { + my $job = $self->{+PROCS}->{$pid}; + next unless $job->isa('Test2::Harness::Runner::Job'); + next unless $job->use_timeout; + + my $et = $job->event_timeout // $self->{+EVENT_TIMEOUT}; + my $pet = $job->post_exit_timeout // $self->{+POST_EXIT_TIMEOUT}; + + next unless $et || $pet; + + my $changed = $job->output_changed(); + my $delta = $now - $changed; + + # Event timout if we are checking for one, and if the delta is larger than the timeout. + my $e_to = $et && $delta > $et; + + # Post-Exit timeout if we are checking for one, the process has exited (we are waiting) and the delta is larger than the timeout. + my $pe_to = $pet && $self->{+WAITING}->{$pid} && $delta > $pet; + + next unless $e_to || $pe_to; + + my $kill = -f $job->et_file || -f $job->pet_file; + + write_file_atomic($job->et_file, "$now $delta") if $e_to && !-f $job->et_file; + write_file_atomic($job->pet_file, "$now $delta") if $pe_to && !-f $job->pet_file; + + my $sigmap = $self->SIG_MAP; + my $sig = $kill ? $sigmap->{'KILL'} : $sigmap->{'TERM'}; + + $sig = "-$sig" if $self->USE_P_GROUPS; + + print STDERR "$$ $0 " . $job->file . " did not respond to SIGTERM, sending SIGKILL to $pid...\n" if $kill; + + # storing the jobid we had to stop + $self->{run_reached_timeout} //= {}; + $self->{run_reached_timeout}->{$job->task->{job_id}} = $pid; + + kill($sig, $pid); + } + + $self->{+LAST_TIMEOUT_CHECK} = time; +} + +sub stop { + my $self = shift; + + $self->check_for_fork; + + if (keys %{$self->{+PROCS}}) { + print "$$ $0 Sending all child processes the TERM signal...\n"; + # Send out the TERM signal + $self->killall($self->{+SIGNAL} // 'TERM'); + $self->wait(all => 1, timeout => 5); + } + + # Time to get serious + if (keys %{$self->{+PROCS}}) { + print STDERR "$$ $0 Some child processes are refusing to exit, sending KILL signal...\n"; + print("$$ $0 == $_ " . waitpid($_, WNOHANG) . "\n") for keys %{$self->{+PROCS}}; + $self->killall('KILL'); + } + + $self->SUPER::stop(); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + return if $self->{+SIGNAL}; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->{+SIGNAL} = $sig; + die "Runner caught SIG$sig. Attempting to shut down cleanly...\n"; +} + +sub all_libs { + my $self = shift; + + my @out; + + push @out => @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + push @out => 't/lib' if $self->{+TLIB}; + push @out => 'lib' if $self->{+LIB}; + + if ($self->{+BLIB}) { + push @out => 'blib/lib'; + push @out => 'blib/arch'; + } + + return @out; +} + +sub process { + my $self = shift; + + @INC = process_includes( + list => [@{$self->settings->harness->dev_libs}, $self->all_libs], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + ); + + my $pidfile = File::Spec->catfile($self->{+DIR}, 'PID'); + write_file_atomic($pidfile, "$$"); + + $self->start(); + + my $ok = eval { $self->run_tests(); 1 }; + my $err = $@; + $self->{+CAN_STAGE} = 0; + + warn $err unless $ok; + + $self->stop(); + + return $self->{+SIGNAL} ? 128 + $self->SIG_MAP->{$self->{+SIGNAL}} : $ok ? 0 : 1; +} + +sub spawn_scheduler { + my $self = shift; + + return unless $self->{+ROOTPID} == $$; + + my $ppid = $$; + + my $pid = fork // die "Could not fork: $!"; + return $self->watch_pid($pid) if $pid; + + my $scheduler; + + my $guard = Scope::Guard->new(sub { + print STDERR "\n\nEscaped Scope!!!!\n\n"; + print STDERR $@; + exit 255; + }); + + $0 =~ s/-runner/-scheduler/i; + + my $state = $self->state; + $state->change_access('scheduler'); + $state->add_yath_process(scheduler => $$, $ppid); + $scheduler = $self->scheduler; + + while (1) { + while (1) { + next if $scheduler->advance; + last; + } + + if ($scheduler->all_done) { + $guard->dismiss; + exit(0); + } + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "Escaped scheduler loop"; + exit 255; +} + +sub run_tests { + my $self = shift; + + my $preloader = $self->preloader; + $preloader->preload(); + + $self->spawn_scheduler(); + + my ($stage, @procs) = $preloader->preload_stages(); + + if ($self->dump_depmap) { + if (my $dtrace = $preloader->dtrace) { + if (my $depmap = $dtrace->dep_map) { + my $file = "depmap-$stage.json"; + write_file($file, encode_json($depmap)); + } + } + } + + $self->watch($_) for @procs; + + while(1) { + $self->{+CAN_STAGE} = 1; + my $jump = setjump "Stage-Runner" => sub { + $self->run_stage($stage); + }; + + last unless $jump; + + ($stage) = @$jump; + $self->reset_stage(); + } + + return; +} + +sub reset_stage { + my $self = shift; + + # Normalize IPC + $self->check_for_fork(); + + # If no stage was set we do not want to clear this, root stages need to + # preserve the preloads + return unless $self->{+STAGE}; + + # From Runner + delete $self->{+STAGE}; + delete $self->{+LAST_TIMEOUT_CHECK}; + + return; +} + +sub run_stage { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE} = $stage; + $self->state->stage_ready($stage, $$); + + while (1) { + next if $self->run_job(); + + next if $self->wait(); + + last if $self->end_test_loop(); + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + $self->state->stage_down($stage); + + $self->killall($self->{+SIGNAL}) if $self->{+SIGNAL}; + + $self->wait(all => 1); + + exit 0 unless $stage eq 'base' || $stage eq 'default'; +} + +sub run_job { + my $self = shift; + + my $scheduler = $self->scheduler; + + my $task = $scheduler->next_task($self->{+STAGE}) or return 0; + + if ($task->{spawn} && !$task->{resource_skip}) { + my $job = Test2::Harness::Runner::Spawn->new( + runner => $self, + task => $task, + settings => $self->settings, + fork_callback => $self->{+FORK_SPAWN_CALLBACK}, + ); + + $self->{+FORK_SPAWN_CALLBACK}->($self, $job); + return 1; + } + + my $state = $self->state; + my $run_data = $state->data->uuid_index->{$task->{run_id}}->{run}; + + my $run = Test2::Harness::Runner::Run->new( + %$run_data, + workdir => $self->workdir, + state => $state, + ); + + my $job_class; + if ($task->{job_class}) { + $job_class = $task->{job_class}; + require(mod2file($job_class)); + + die "Custom job class $job_class overrode the category, this is a fatal mistake" + unless $job_class->category eq $self->job_class->category; + } + else { + $job_class = $self->job_class; + } + + my $job = $job_class->new( + runner => $self, + task => $task, + run => $run, + settings => $self->settings, + fork_callback => $self->{+FORK_JOB_CALLBACK}, + ); + + $job->prepare_dir(); + + my $spawn_time; + + my $pid; + my $via = $job->via(); + if ($via) { + require(mod2file($1)) if !defined(&{$via}) && $via =~ m/^(.+)::[^:]+$/; + + $spawn_time = time(); + $pid = $self->$via($job); + $job->set_pid($pid); + $self->watch($job); + } + else { + $spawn_time = time(); + $self->spawn($job); + $pid = $job->pid; + } + + $self->state->start_job( + job_id => $job->job_id, + pid => $pid, + parent_pid => $$, + stamp => $spawn_time, + ); + + return $pid; +} + +sub end_test_loop { + my $self = shift; + + my $state = $self->state; + + no warnings 'uninitialized'; + if (!$self->{+STAGE} || $self->{+STAGE} eq 'default' || $self->{+STAGE} eq 'base') { + $self->{+RESPAWN_RUNNER_CALLBACK}->() + if $self->preloader->check($state) || ($self->{+SIGNAL} && $self->{+SIGNAL} eq 'HUP'); + } + + if ($self->preloader->check()) { + $self->{+SIGNAL} //= 'HUP'; + return 1; + } + + return 1 if $self->{+SIGNAL}; + + return 1 if $self->scheduler->all_done; + + return 0; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, $exit, $time, @args) = @_; + + if ($proc->isa('Test2::Harness::Runner::Job')) { + my $task = $proc->task; + + my $timed_out = 0; + if ( !$exit && ref $self->{run_reached_timeout} && $self->{run_reached_timeout}->{ $task->{job_id} } ) { + delete $self->{run_reached_timeout}->{ $task->{job_id} }; + $timed_out = 1; + } + + if (($exit || $timed_out) && $proc->is_try < $proc->retry ) { + $self->state->retry_job($task->{job_id}); + push @args => 'will-retry'; + } + else { + $self->state->stop_job($task->{job_id}); + } + + if(my $bail = $exit ? $proc->bailed_out : 0) { + print "$$ $0 BAIL-OUT detected: $bail\n"; + if ($self->settings->runner->abort_on_bail) { + print "$$ $0 Aborting the test run...\n"; + $self->scheduler->halt_run($task->{run_id}); + } + } + } + elsif ($proc->isa('Test2::Harness::Runner::Preloader::Stage')) { + my $stage = $proc->name; + + if ($exit != 0) { + my $e = parse_exit($exit); + my $err = "$$ $0 Child stage '$stage' did not exit cleanly (sig: $e->{sig}, err: $e->{err})!\n"; + $self->{+MONITOR_PRELOADS} ? warn $err : die $err; + } + + if ($self->{+MONITOR_PRELOADS} && $self->{+CAN_STAGE} && !$self->end_test_loop) { + my $pid = $$; + my ($name, @procs) = $self->preloader->_preload_stages($stage); + $self->watch($_) for @procs; + longjump "Stage-Runner" => $name unless $pid == $$; + } + } + + $self->SUPER::set_proc_exit($proc, $exit, $time, @args); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner - Base class for test runners + +=head1 DESCRIPTION + +This module does the heavy lifting of running all the tests. + +You should never need to create an instance of the runner yourself. In most +cases the runner module is exposed via a callback or a plugin affordance. + +=head1 PUBLIC METHODS + +=head2 FROM SETTINGS + +These are attributesd with values set from the L<Test2::Harness::Settings> +instance created from command line arguments. + +See L<App::Yath::Options::Runner> for the most up to date documentation on +these. + +=over 4 + +=item $runner->includes + +=item $runner->tlib + +=item $runner->lib + +=item $runner->blib + +=item $runner->unsafe_inc + +=item $runner->use_fork + +=item $runner->preloads + +=item $runner->preload_threshold + +=item $runner->switches + +=item $runner->cover + +=item $runner->event_timeout + +=item $runner->post_exit_timeout + +=back + +=head2 FROM CONSTRUCTION + +These attributes are set when the runner is created. + +=over 4 + +=item $path = $runner->dir + +Path to the working directory. + +=item $settings = $runner->settings + +The L<App::Yath::Settings> instance. + +=item $coderef = $runner->fork_job_callback + +Callback used to spawn new tests via fork. + +=item $coderef = $runner->respawn_runner_callback + +Callback to restart the runner process. + +=item $bool = $runner->monitor_preloads + +True if preloads should be watched for changes. + +=item $int = $runner->jobs_todo + +A count of total jobs to run. This will always be 0 in a persistent runner. + +=back + +=head2 OTHER PUBLIC METHODS + +If a method is not documented here then it is an implementation detail and you +should not use it. + +=over 4 + +=item $class = $runner->job_class + +Class for new test jobs. + +=item $preload = $runner->preloader + +Get the L<Test2::Harness::Runner::Preloader> instance. + +=item $state = $runner->state + +Get the L<Test2::Harness::Runner::State> instance. + +=item @list = $runner->all_libs + +Get all the libs that should be added to @INC by default. Note that specific +runs and even specific tests can have custom paths on top of these. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Constants.pm b/bad/Test2/Harness/Runner/Constants.pm new file mode 100644 index 000000000..ce20a0380 --- /dev/null +++ b/bad/Test2/Harness/Runner/Constants.pm @@ -0,0 +1,72 @@ +package Test2::Harness::Runner::Constants; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT = qw/CATEGORIES DURATIONS/; + +use constant CATEGORIES => {general => 1, isolation => 1, immiscible => 1}; +use constant DURATIONS => {long => 1, medium => 1, short => 1}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Constants - Constants shared between multiple runner +modules. + +=head1 DESCRIPTION + +Export some common structures. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::Constants qw/CATEGORIES DURATIONS/; + + if (CATEGORIES->{$cat}) { + print "$cat is valid\n"; + } + else { + print "$cat is not valid\n"; + } + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/DepTracer.pm b/bad/Test2/Harness/Runner/DepTracer.pm new file mode 100644 index 000000000..301ad0855 --- /dev/null +++ b/bad/Test2/Harness/Runner/DepTracer.pm @@ -0,0 +1,283 @@ +package Test2::Harness::Runner::DepTracer; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw/ + -_on + -exclude + -dep_map + -loaded + -my_require + -real_require + -_my_inc + -callbacks +/; + +my %DEFAULT_EXCLUDE = ( + 'warnings.pm' => 1, + 'strict.pm' => 1, +); + +my $ACTIVE; + +sub ACTIVE { $ACTIVE } + +sub start { + my $self = shift; + + croak "There is already an active DepTracer" if $ACTIVE; + + $ACTIVE = $self; + + unshift @INC => $self->my_inc; + + $self->{+_ON} = 1; +} + +sub stop { + my $self = shift; + + croak "DepTracer is not active" unless $ACTIVE; + croak "Different DepTracer is active" unless "$ACTIVE" eq "$self"; + $ACTIVE = undef; + + $self->{+_ON} = 0; + + my $inc = $self->{+_MY_INC} or return 0; + + @INC = grep { !(ref($_) && $inc == $_) } @INC; + return 0; +} + +sub my_inc { + my $self = shift; + + return $self->{+_MY_INC} if $self->{+_MY_INC}; + + my $exclude = $self->{+EXCLUDE} ||= {%DEFAULT_EXCLUDE}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + + return $self->{+_MY_INC} ||= sub { + my ($this, $file) = @_; + + return unless $self->{+_ON}; + return unless $file =~ m/^[_a-z]/i; + return if $exclude->{$file}; + + my $loaded_by = $self->loaded_by; + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + + return; + }; +} + +sub clear_loaded { %{$_[0]->{+LOADED}} = () } + +my %REQUIRE_CACHE; + +sub add_callbacks { + my $self = shift; + my %watch = @_; + for my $file (keys %watch) { + my $cb = $watch{$file}; + $self->add_callback($file => $cb); + } +} + +sub add_callback { + my $self = shift; + my ($file, $cb) = @_; + $self->{+LOADED}->{$file}++; + $self->{+CALLBACKS}->{$file} = $cb; +} + +sub init { + my $self = shift; + + my $exclude = $self->{+EXCLUDE} ||= { %DEFAULT_EXCLUDE }; + + my $stash = \%CORE::GLOBAL::; + # We use a string in the reference below to prevent the glob slot from + # being auto-vivified by the compiler. + $self->{+REAL_REQUIRE} = exists $stash->{require} ? \&{'CORE::GLOBAL::require'} : undef; + + $self->{+CALLBACKS} //= {}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + my $inc = $self->my_inc; + + my $require = $self->{+MY_REQUIRE} = sub { + my ($file) = @_; + + my $loaded_by = $self->loaded_by; + + my $real_require = $self->{+REAL_REQUIRE}; + unless($real_require) { + my $caller = $loaded_by->[0]; + $real_require = $REQUIRE_CACHE{$caller} ||= eval "package $caller; sub { CORE::require(\$_[0]) }" or die $@; + } + + goto &$real_require unless $self->{+_ON}; + + if ($file =~ m/^[_a-z]/i) { + unless ($exclude->{$file}) { + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + } + } + + if (!ref($INC[0]) || $INC[0] != $inc) { + @INC = ( + $inc, + grep { !(ref($_) && $inc == $_) } @INC, + ); + } + + local @INC = @INC[1 .. $#INC]; + + $real_require->(@_); + }; + + { + no strict 'refs'; + no warnings 'redefine'; + *{'CORE::GLOBAL::require'} = $require; + } +} + +sub loaded_by { + my $level = 1; + + while(my @caller = caller($level++)) { + next if $caller[0] eq __PACKAGE__; + + return [$caller[0], $caller[1]]; + } + + return ['', '']; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::DepTracer - Tool for tracing module dependencies as +they are loaded. + +=head1 DESCRIPTION + +This tool is used by Test2::Harness to build a graph of dependancies which can +then be used to blacklist modified modules (and anything thatuses them) when +they change under a preloaded runner. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::DepTracer; + + my $dt = Test2::Harness::Runner::DepTracer->new(); + + $dt->start(); + + require Some::Thing; + + # You can always check for and retrieve an active DepTrace this way: + my $dt_reference = Test2::Harness::Runner::DepTracer->ACTIVE; + + $dt->stop(); + + my $dep_map = $dt->dep_map; + + my $loaded_by = $dep_map->{'Some/Thing.pm'}; + print "Some::Thing was directly or indirectly loaded by:\n" . join("\n" => @$loaded_by) . "\n"; + +=head1 ATTRIBUTES + +These can be specified at construction, and will be populated during use. + +=over 4 + +=item $hashref = $dt->exclude + +A hashref of files/modules to exclude from dep tracking. By default C<strict> +and C<warnings> are excluded. + +=item $hashref = $dt->dep_map + +Every file which is loaded while the tool is started will have an entry in this +hash, each value is an array of all files which loaded the key file directly or +indirectly. + +=item $hashref = $dt->loaded + +How many times each file was directly loaded. + +=back + +=head1 METHODS + +=over 4 + +=item $dt->start + +Start tracking modules which are loaded. + +=item $dt->stop + +Stop tracking moduels that are loaded. + +=back + +=head1 CLASS METHODS + +=over 4 + +=item $dt_or_undef = Test2::Harness::Runner::DepTracer->ACTIVE(); + +Get the currently active DepTracer, if any. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Job.pm b/bad/Test2/Harness/Runner/Job.pm new file mode 100644 index 000000000..7129d5913 --- /dev/null +++ b/bad/Test2/Harness/Runner/Job.pm @@ -0,0 +1,827 @@ +package Test2::Harness::Runner::Job; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess croak/; +use Config qw/%Config/; +use List::Util qw/min/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/CAN_REALLY_FORK/; +use Time::HiRes qw/time/; + +use File::Spec(); +use File::Temp(); + +use Test2::Harness::Util qw/fqmod clean_path write_file_atomic write_file mod2file open_file parse_exit process_includes chmod_tmp/; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase( + qw{ <task <runner <run <settings }, # required + qw{ + <fork_callback + <last_output_size + +output_changed + + +verbose + + +via + + +run_dir +job_dir +tmp_dir +event_dir + + +ch_dir +unsafe_inc + + +use_fork +use_w_switch + + +includes +runner_includes + +switches + +use_stream + +cli_includes + +cli_options + + +smoke + +retry +retry_isolated +is_try + + +args +file +run_file + + +out_file +err_file +in_file +bail_file + + +load +load_import + + +event_uuids +mem_usage +io_events + + +env_vars + + +event_timeout +post_exit_timeout +use_timeout + + +switches_from_env + + +et_file +pet_file + + +min_slots + +max_slots + } +); + +sub category { 'job' } + +sub init { + my $self = shift; + + croak "'runner' is a required attribute" unless $self->{+RUNNER}; + croak "'run' is a required attribute" unless $self->{+RUN}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + delete $self->{+JOB_DIR}; + + # Avoid a ref cycle + #weaken($self->{+RUNNER}); + + my $task = $self->{+TASK} or croak "'task' is a required attribute"; + + delete $self->{+LAST_OUTPUT_SIZE}; + + confess "Task does not have a job ID" unless $task->{job_id}; + confess "Task does not have a file" unless $task->{file}; +} + +sub job_id { $_[0]->{+TASK}->{job_id} } + +sub prepare_dir { + my $self = shift; + + $self->job_dir(); + $self->tmp_dir(); + $self->event_dir(); +} + +sub via { + my $self = shift; + + return undef if $self->{+SETTINGS}->debug->dummy; + return undef if $self->{+TASK}->{resource_skip}; + + return $self->{+VIA} if exists $self->{+VIA}; + + my $task = $self->{+TASK}; + return $self->{+VIA} = $task->{via} if $task->{via}; + + return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork; + + return $self->{+VIA} = undef; +} + +sub spawn_params { + my $self = shift; + + my $task = $self->{+TASK}; + + my $skip; + $skip = 'dummy mode' if $self->{+SETTINGS}->debug->dummy; + $skip = "Some resources are not available: " . join(', ' => @{$self->{+TASK}->{resource_skip}}) if $self->{+TASK}->{resource_skip}; + + my $command; + if (!$skip && $task->{binary} || $task->{non_perl}) { + my $file = $self->ch_dir ? $self->file : $self->rel_file; + $command = [clean_path($file), $self->args]; + } + else { + $command = [ + $^X, + $self->cli_includes, + $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (), + $self->switches, + $self->cli_options, + + $skip ? ('-e', "print \"1..0 # SKIP $skip\"") : (sub { $self->run_file }), + + $self->args, + ]; + } + + my $out_fh = open_file($self->out_file, '>'); + my $err_fh = open_file($self->err_file, '>'); + my $in_fh = open_file($self->in_file, '<'); + + return { + command => $command, + stdin => $in_fh, + stdout => $out_fh, + stderr => $err_fh, + chdir => $self->ch_dir(), + env => $self->env_vars(), + }; +} + +sub switches_from_env { + my $self = shift; + + return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV}; + + return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES}; + + return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]}; +} + +my %JSON_SKIP = ( + SETTINGS() => 1, + TASK() => 1, + RUNNER() => 1, + RUN() => 1, + CLI_INCLUDES() => 1, + CLI_OPTIONS() => 1, + ERR_FILE() => 1, + ET_FILE() => 1, + EVENT_DIR() => 1, + EXIT() => 1, + EXIT_TIME() => 1, + IN_FILE() => 1, + JOB_DIR() => 1, + LAST_OUTPUT_SIZE() => 1, + OUT_FILE() => 1, + BAIL_FILE() => 1, + OUTPUT_CHANGED() => 1, + PET_FILE() => 1, + RUN_DIR() => 1, + TMP_DIR() => 1, +); + +sub TO_JSON { + my $self = shift; + + my $out = { %{$self->{+TASK}} }; + + for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) { + next if $JSON_SKIP{$attr}; + $self->$attr unless defined $self->{$attr}; + $out->{$attr} = $self->{$attr}; + } + + delete $out->{+FORK_CALLBACK}; + delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE'; + + $out->{job_name} //= $out->{job_id}; + $out->{abs_file} = clean_path($self->file); + + return $out; +} + +sub run_file { + my $self = shift; + return $self->{+RUN_FILE} //= $self->rel_file; +} + +sub rel_file { File::Spec->abs2rel($_[0]->file) } +sub file { $_[0]->{+FILE} //= clean_path($_[0]->{+TASK}->{file}, 0) } +sub err_file { $_[0]->{+ERR_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) } +sub out_file { $_[0]->{+OUT_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) } +sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) } +sub et_file { $_[0]->{+ET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) } +sub pet_file { $_[0]->{+PET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) } +sub run_dir { $_[0]->{+RUN_DIR} //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) } + +sub bailed_out { + my $self = shift; + + if(-f $self->bail_file) { + my $fh = open_file($self->bail_file, '<'); + my $reason = <$fh> || 1; + return $reason; + } + + my $fh = open_file($self->out_file, '<'); + while (my $line = <$fh>) { + next unless $line =~ m/^Bail out!\s*(.*)$/; + return $1 || 1; + } + + return ""; +} + +sub output_size { + my $self = shift; + + my $size = 0; + + $size += -s $self->err_file || 0; + $size += -s $self->out_file || 0; + + return $self->{+LAST_OUTPUT_SIZE} = $size; +} + +sub output_changed { + my $self = shift; + + my $last = $self->{+LAST_OUTPUT_SIZE}; + my $size = $self->output_size(); + + # Output changed, update time + return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last; + + # Return the last recorded time, if there is no previously recorded time then the record starts now + return $self->{+OUTPUT_CHANGED} //= time(); +} + +sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 } +sub is_try { $_[0]->{+IS_TRY} //= $_[0]->{+TASK}->{is_try} // 0 } +sub ch_dir { $_[0]->{+CH_DIR} //= $_[0]->{+TASK}->{ch_dir} // '' } +sub unsafe_inc { $_[0]->{+UNSAFE_INC} //= $_[0]->{+RUNNER}->unsafe_inc } +sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids } +sub mem_usage { $_[0]->{+MEM_USAGE} //= $_[0]->run->mem_usage } + +sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) } + +sub smoke { $_[0]->{+SMOKE} //= $_[0]->_fallback(smoke => 0, qw/task/) } +sub retry_isolated { $_[0]->{+RETRY_ISOLATED} //= $_[0]->_fallback(retry_isolated => 0, qw/task run/) } +sub use_stream { $_[0]->{+USE_STREAM} //= $_[0]->_fallback(use_stream => 1, qw/task run/) } +sub use_timeout { $_[0]->{+USE_TIMEOUT} //= $_[0]->_fallback(use_timeout => 1, qw/task/) } +sub retry { $_[0]->{+RETRY} //= $_[0]->_fallback(retry => undef, qw/task run/) } +sub event_timeout { $_[0]->{+EVENT_TIMEOUT} //= $_[0]->_fallback(event_timeout => undef, qw/task runner/) } +sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) } + +sub min_slots { $_[0]->{+MIN_SLOTS} //= $_[0]->_fallback_non_bool(min_slots => 1, qw/task/) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_fallback_non_bool(max_slots => 1, qw/task/) } + +sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} } +sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} } + +sub cli_includes { + my $self = shift; + + # '.' is handled via the PERL_USE_UNSAFE_INC env var set later + $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes]; + + return @{$self->{+CLI_INCLUDES}}; +} + +sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} } + +sub _merge_sources { + my $self = shift; + my ($name, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + next unless defined $val; + next unless @$val; + push @vals => @$val; + } + + return \@vals; +} + +sub _fallback_non_bool { + my $self = shift; + my ($name, $default, @from) = @_; + + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + return $val if defined $val; + } + + return $default; +} + +sub _fallback { + my $self = shift; + my ($name, $default, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + push @vals => $val if defined $val; + } + + return $default unless @vals; + + # If the default is a ref we will just return the first value we found, truthiness check is useless + return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/; + + # If the default is true, then we only return true if none of the vals are false + return !grep { !$_ } @vals if $default; + + # If the default is false, then we return true if any of the valse are true + return grep { $_ } @vals; +} + +sub job_dir { + my $self = shift; + return $self->{+JOB_DIR} if $self->{+JOB_DIR}; + + my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try); + mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!"; + chmod_tmp($job_dir); + $self->{+JOB_DIR} = $job_dir; +} + +sub tmp_dir { + my $self = shift; + + return $self->{+TMP_DIR} if $self->{+TMP_DIR}; + + my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir); + chmod_tmp($tmp_dir); + + $self->{+TMP_DIR} = clean_path($tmp_dir); +} + +sub make_event_dir { $_[0]->event_dir } +sub event_dir { + my $self = shift; + return $self->{+EVENT_DIR} if $self->{+EVENT_DIR}; + + my $events_dir = File::Spec->catdir($self->job_dir, 'events'); + unless (-d $events_dir) { + mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!"; + } + $self->{+EVENT_DIR} = $events_dir; +} + +sub in_file { + my $self = shift; + return $self->{+IN_FILE} if $self->{+IN_FILE}; + + my $task = $self->{+TASK}; + + unless ($task->{input}) { + my $from_run = $self->run->input_file; + return $self->{+IN_FILE} = $from_run if $from_run; + } + + my $stdin = File::Spec->catfile($self->job_dir, 'stdin'); + + my $content = $task->{input} // $self->run->input // ''; + write_file($stdin, $content); + + return $self->{+IN_FILE} = $stdin; +} + +sub use_fork { + my $self = shift; + + return $self->{+USE_FORK} if defined $self->{+USE_FORK}; + + my $task = $self->{+TASK}; + + return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK; + return $self->{+USE_FORK} = 0 if $task->{binary}; + return $self->{+USE_FORK} = 0 if $task->{non_perl}; + return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork}; + return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload}; + + # -w switch is ok, otherwise it is a no-go + return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches; + + my $runner = $self->{+RUNNER}; + return $self->{+USE_FORK} = 0 unless $runner->use_fork; + + return $self->{+USE_FORK} = 1; +} + +sub includes { + my $self = shift; + + return @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + $self->{+INCLUDES} = [ + process_includes( + list => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + $self->ch_dir ? (ch_dir => $self->ch_dir) : (), + ) + ]; + + return @{$self->{+INCLUDES}}; +} + +sub cli_options { + my $self = shift; + + my $event_dir = $self->event_dir; + my $job_id = $self->job_id; + + return ( + $self->use_stream ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (), + $self->event_uuids ? ('-MTest2::Plugin::UUID') : (), + $self->mem_usage ? ('-MTest2::Plugin::MemUsage') : (), + $self->io_events ? ('-MTest2::Plugin::IOEvents') : (), + (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import), + (map { "-m$_" } $self->load), + ); +} + +sub switches { + my $self = shift; + + return @{$self->{+SWITCHES}} if $self->{+SWITCHES}; + + my @switches; + + my %seen; + for my $s (@{$self->{+TASK}->{switches} // []}) { + $seen{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + my %seen2; + for my $s (@{$self->{+RUNNER}->switches // []}) { + next if $seen{$s}; + $seen2{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + for my $s ($self->switches_from_env) { + next if $seen{$s}; + next if $seen2{$s}; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + return @{$self->{+SWITCHES} = \@switches}; +} + +sub prof_file { + my $self = shift; + my $file =$self->rel_file; + + $file =~ s{/}{-}g; + $file =~ s{\.[^\.]+$}{.nytprof}g; + + return $file; +} + +sub env_vars { + my $self = shift; + + return $self->{+ENV_VARS} if $self->{+ENV_VARS}; + + my $from_run = $self->run->env_vars; + my $from_task = $self->{+TASK}->{env_vars}; + + my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB}); + push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl}; + push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB}; + my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l; + + my $verbose = $self->verbose; + + return $self->{+ENV_VARS} = { + $from_run ? (%$from_run) : (), + $from_task ? (%$from_task) : (), + + $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (), + + $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (), + + PERL5LIB => $p5l, + PERL_USE_UNSAFE_INC => $self->unsafe_inc, + TEST2_JOB_DIR => $self->job_dir, + TEST2_RUN_DIR => $self->run_dir, + TMPDIR => $self->tmp_dir, + TEMPDIR => $self->tmp_dir, + SYSTEM_TMPDIR => $self->{+SETTINGS}->harness->orig_tmp, + SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms, + + HARNESS_IS_VERBOSE => $verbose, + T2_HARNESS_IS_VERBOSE => $verbose, + + HARNESS_ACTIVE => 1, + TEST2_HARNESS_ACTIVE => 1, + + T2_HARNESS_JOB_FILE => $self->rel_file, + T2_HARNESS_JOB_NAME => $self->{+TASK}->{job_name}, + T2_HARNESS_JOB_IS_TRY => $self->{+IS_TRY} // 0, + T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '', + }; +} + +sub load_import { + my $self = shift; + + return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT}; + + my $from_run = $self->run->load_import; + + my @out; + for my $mod (@{$from_run->{'@'} // []}) { + push @out => [$mod, $from_run->{$mod} // []]; + } + + return @{$self->{+LOAD_IMPORT} = \@out}; +} + +sub use_w_switch { + my $self = shift; + return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH}; + $self->switches; + return $self->{+USE_W_SWITCH}; +} + +sub set_exit { + my $self = shift; + my ($runner, $exit, $time, @args) = @_; + + $self->SUPER::set_exit(@_); + + my $file = File::Spec->catfile($self->job_dir, 'exit'); + + my $e = parse_exit($exit); + + write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Job - Representation of a test job. + +=head1 DESCRIPTION + +This module takes all the data from a test file queue item, a run, and runner +settings, and mashes them together to figure out what is actually needed to run +a job. + +=head1 METHODS + +Note, this object subclasses L<Test2::Harness::IPC::Process>. + +=over 4 + +=item $arrayref = $job->args + +Get the arguments for the test either formt he queue item, or from the run. + +=item $path = $job->bail_file + +Path to the events-file used in case of a bail-out + +=item $bool = $job->bailed_out + +True if the test job bailed out. + +=item $cat $job->category + +Process category, always 'job' unless overriden in a subclass. + +=item $path = $job->ch_dir + +If this job first requires a change in directory before running, this will +return the path. + +=item @list = $job->cli_includes + +List of includes for a command line launch of this job. + +=item @list = $job->cli_options + +List of options for a command line launch of this job. + +=item $hashref = $job->env_vars + +Get environment variables to set when launching this job. + +=item $path = $job->out_file + +File to which all STDOUT for the job will be written. + +=item $path = $job->err_file + +File to which all STDERR for the job will be written. + +=item $path = $job->et_file + +File to which event timeout notifications will be written. + +=item $path = $job->pet_file + +File to which post exit timeout events will be written. + +=item $path = $job->event_dir + +Directory to which L<Test2::Formatter::Stream> events will be written. + +=item $time = $job->event_timeout + +Event timeout specification, if any, first from test queue item, then from +runner. + +=item $time = $job->post_exit_timeout + +Post exit timeout specification, if any, first from test queue item, then from +runner. + +=item $bool = $job->event_uuids + +Use L<Test2::Plugin::UUID> inside the test. + +=item $path = $job->file + +Test file the job will be running. + +=item $coderef = $job->fork_callback + +If the job is to be launched via fork, use this callback. + +=item $path = $job->in_file + +File containing STDIN to be provided to the test. + +=item @list = $job->includes + +Paths to add to @INC for the test. + +=item $bool = $job->io_events + +True if L<Test2::Plugin::IOEvents> should be used. + +=item $int = $job->is_try + +This starts at 0 and will be incremented for every retry of the job. + +=item $path = $job->job_dir + +Temporary directory housing all files related to this job when it runs. + +=item $uuid = $job->job_id + +UUID for this job. + +=item @list = $job->load + +Modules to load when starting this job. + +=item @list = $job->load_import + +Modules to load and import when starting this job. + +=item $bool = $job->mem_usage + +True if the L<Test2::Plugin::MemUsage> plugin should be used. + +=item $path = $job->run_file + +Usually the same as rel_file, but you can specify an alternative file to +actually run. + +=item $path = $job->rel_file + +Relative path to the file. + +=item $int = $job->retry + +How many times the test should be retried if it fails. + +=item $bool = $job->retry_isolated + +True if the test should be retried in isolation if it fails. + +=item $run = $job->run + +The L<Test2::Harness::Runner::Run> instance. + +=item $path = $job->run_dir + +Path to the temporary directory housing all the data about the run. + +=item $runner = $job->runner + +The L<Test2::Harness::Runner> instance. + +=item @list = $job->runner_includes + +Search path includes provided directly by the runner. + +=item $settings = $job->settings + +The L<Test2::Harness::Settings> instance. + +=item $bool = $job->smoke + +True if the test is a priority smoke test. + +=item $hashref = $job->spawn_params + +Parameters for C<run_cmd()> in L<Test2::Harness::Util::IPC> when launching this +job. + +=item @list = $job->switches + +Command line switches for perl when running this test. + +=item $hashref = $job->task + +Task data from the queue. + +=item $path = $job->tmp_dir + +Temp dir created specifically for this job. + +=item $bool = $job->unsafe_inc + +True if '.' should be added to C<@INC>. + +=item $bool = $job->use_fork + +True if this job should be launched via fork. + +=item $bool = $job->use_stream + +True if this job should use L<Test2::Formatter::Stream>. + +=item $bool = $job->use_timeout + +True if this job should timeout due to lack of activity. + +=item $bool = $job->use_w_switch + +True if the C<-w> switch should be used for this test. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Preload.pm b/bad/Test2/Harness/Runner/Preload.pm new file mode 100644 index 000000000..f09708fc7 --- /dev/null +++ b/bad/Test2/Harness/Runner/Preload.pm @@ -0,0 +1,569 @@ +package Test2::Harness::Runner::Preload; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Runner::Preload::Stage(); + +sub import { + my $class = shift; + my $caller = caller; + + my %exports; + + my $instance = $class->new; + + $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; + + $exports{stage} = sub { + my ($name, $code) = @_; + my @caller = caller(); + $instance->build_stage( + name => $name, + code => $code, + caller => \@caller, + ); + }; + + $exports{eager} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_eager(1); + }; + + $exports{default} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + my $name = $stage->name; + $instance->set_default_stage($name); + }; + + $exports{file_stage} = sub { + my ($callback) = @_; + my @caller = caller(); + croak "'file_stage' cannot be used under a stage" if @{$instance->stack}; + $instance->add_file_stage(\@caller, $callback); + }; + + for my $name (qw/pre_fork post_fork pre_launch/) { + my $meth = "add_${name}_callback"; + $exports{$name} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->$meth(@_); + }; + } + + $exports{watch} = sub { + if (@{$instance->stack}) { + my $stage = $instance->stack->[-1]; + return $stage->watch(@_); + } + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + return $active->add_callback(@_); + } + } + + croak "No current stage, and no active deptracer"; + }; + + $exports{preload} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->add_to_load_sequence(@_); + }; + + $exports{reload_remove_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_remove_check(@_); + }; + + $exports{reload_inplace_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_inplace_check(@_); + }; + + for my $name (keys %exports) { + no strict 'refs'; + *{"$caller\::$name"} = $exports{$name}; + } +} + +use Test2::Harness::Util::HashBase qw{ + <stage_list + <stage_lookup + <stack + +default_stage + +file_stage +}; + +sub init { + my $self = shift; + + $self->{+STAGE_LIST} //= []; + $self->{+STAGE_LOOKUP} //= {}; + + $self->{+STACK} //= []; + + $self->{+FILE_STAGE} //= []; +} + +sub build_stage { + my $self = shift; + my %params = @_; + + my $caller = $params{caller} //= [caller()]; + + die "A coderef is required at $caller->[1] line $caller->[2].\n" + unless $params{code}; + + my $stage = Test2::Harness::Runner::Preload::Stage->new( + stage_lookup => $self->{+STAGE_LOOKUP}, + %params, + ); + + my $stack = $self->{+STACK} //= []; + push @$stack => $stage; + + my $ok = eval { $params{code}->($stage); 1 }; + my $err = $@; + + die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; + + pop @$stack; + + die $err unless $ok; + + if (@$stack) { + $stack->[-1]->add_child($stage); + } + else { + $self->add_stage($stage, $caller); + } + + return $stage; +} + +sub add_stage { + my $self = shift; + my ($stage, $caller) = @_; + + $caller //= [caller()]; + + my @all = ($stage, @{$stage->all_children}); + + for my $item (@all) { + my $name = $item->name; + + if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { + $caller //= [caller()]; + my $ncaller = $item->frame; + my $ecaller = $existing->frame; + die <<" EOT" +A stage named '$name' was already defined. + First at $ecaller->[1] line $ecaller->[2]. + Second at $ncaller->[1] line $ncaller->[2]. + Mixed at $caller->[1] line $caller->[2]. + EOT + } + + $self->{+STAGE_LOOKUP}->{$name} = $item; + } + + push @{$self->{+STAGE_LIST}} => $stage; +} + +sub merge { + my $self = shift; + my ($merge) = @_; + + my $caller = [caller()]; + + for my $stage (@{$merge->{+STAGE_LIST}}) { + $self->add_stage($stage, $caller); + } + + push @{$self->{+FILE_STAGE}} => @{$merge->{+FILE_STAGE}}; + + $self->{+DEFAULT_STAGE} //= $merge->default_stage; +} + +sub add_file_stage { + my $self = shift; + my ($caller, $code) = @_; + + croak "Caller must be defined and an array" unless $caller && ref($caller) eq 'ARRAY'; + croak "Code must be defined and a coderef" unless $code && ref($code) eq 'CODE'; + + push @{$self->{+FILE_STAGE}} => [$caller, $code]; +} + +sub file_stage { + my $self = shift; + my ($file) = @_; + + for my $cb (@{$self->{+FILE_STAGE}}) { + my ($caller, $code) = @$cb; + my $stage = $code->($file) or next; + + die "file_stage callback returned invalid stage: $stage at $caller->[1] line $caller->[2].\n" + unless $self->{+STAGE_LOOKUP}->{$stage}; + + return $stage; + } + + return; +} + +sub default_stage { + my $self = shift; + return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; + return $self->{+STAGE_LIST}->[0]; +} + +sub set_default_stage { + my $self = shift; + my ($name) = @_; + + croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; + $self->{+DEFAULT_STAGE} = $name; +} + +sub eager_stages { + my $self = shift; + + my %eager; + + for my $root (@{$self->{+STAGE_LIST}}) { + for my $stage ($root, @{$root->all_children}) { + next unless $stage->eager; + $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; + } + } + + return \%eager; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload - DSL for building complex stage-based preload +tools. + +=head1 DESCRIPTION + +L<Test2::Harness> allows you to preload libraries for a performance boost. This +module provides tools that let you go beyond that and build a more complex +preload. In addition you can build multiple preload I<stages>, each stage will +be its own process and tests can run from a specific stage. This allows for +multiple different preload states from which to run tests. + +=head1 SYNOPSIS + +=head2 USING YOUR PRELOAD + +The C<-P> or C<--preload> options work for custom preload modules just as they +do regular modules. Yath will know the difference and act accordingly. + + yath test -PMy::Preload + +=head2 WRITING YOUR PRELOAD + + package My::Preload; + use strict; + use warnings; + + # This imports several useful tools, and puts the necessary meta-data in + # your package to identify it as a special preload. + use Test2::Harness::Runner::Preload; + + # You must specify at least one stage. + stage Moose => sub { + # Preload can be called multiple times, and can load multiple modules + # per call. Order is preserved. + preload 'Moose', 'Moose::Role'; + preload 'Scalar::Util', 'List::Util'; + + # preload can also be given a sub if you have some custom code to run + # at a specific point in the load order + preload sub { + # Do something before loading Try::Tiny + ... + }; + + preload 'Try::Tiny'; + + # Tell the runner to watch this file for changes, if it does change run + # the sub instead of the usual reload process. This lets you reload + # configs and other non-perl files, or allows you to use a custom + # reload sub for perl files. + watch 'path/to/file' => sub { ... }; + + # You can also use watch inside preload subs: + preload sub { + watch 'path/to/file' => sub { ... }; + }; + + # In app code you can add watches dynamically when applicable: + preload sub { + ... # inside app code + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + $active->add_callback('path/to/file' => sub { ... }); + } + } + + ... + }; + + # Eager means tests from nested stages can be run in this stage as + # well, this is useful if the nested stage takes a long time to load as + # it allows yath to start running tests sooner instead of waiting for + # the stage to finish loading. Once the nested stage is loaded tests + # intended for it will start running from it instead. + eager(); + + # default means this stage is the one to use if the test does not + # specify a stage. + default(); + + # These are hooks that let you run arbitrary code at specific points in + # the process. pre_fork happens just before forking to run a test. + # post_fork happens just after forking for a test. pre_launch happens + # as late as possible before the test starts executing (post fork, + # after $0 and other special state are reset). + pre_fork sub { ... }; + post_fork sub { ... }; + pre_launch sub { ... }; + + # Stages can be nested, nested ones build off the previous stage, but + # are in a forked process to avoid contaminating the parent. + stage Types => sub { + preload 'MooseX::Types'; + }; + }; + + # Alternative stage that loads Moo instead of Moose + stage Moo => sub { + preload 'Moo'; + + ... + }; + +=head2 HARNESS DIRECTIVES IN PRELOADS + +If you use a staged preload, and the --reload option, you can add 'CHURN' +directives to files in order to only reload sections you are working on. This +is particularly useful when a file cannot be reloaded in full, or when doing so +is expensive. You can wrap subroutines in the churn directives to have yath +reload only those subroutines. + + sub do_not_reload_this { ... { + + # HARNESS-CHURN-START + + sub reload_this_one { + ... + } + + sub reload_this_one_too { + ... + } + + # HARNESS-CHURN-STOP + + sub this_is_not_reloaded { ... } + +You can put as many churn sections you want in as many preloaded modules as you +want. If a change is detected then only the churn sections will be reloaded. +The churn sections are reloaded by taking the source between the start and stop +markers, and running them in an eval like this: + + eval <<EOT + package MODULE_FROM_FILENAME; + use strict; + use warnings; + no warnings 'redefine'; + #line $line_number $file + $YOUR_CODE + ;1; + EOT + +In most cases this is sufficient to replace the old sub with the new one. If +the automatically determined package is not correct you can add a C<package +FOO;> statement inside the markers. If the strict/warnings settings are not to +your specifications you can add overrides inside the markers. Any valid perl +code can go into the markers. + +B<CAVEATS:> Be aware they do not have their original scope, and that can lead +to problems if you are not paying attention. Variables outside your markers are +not accessible, and lexical variables put inside your markers will be "new" on +each reload, this can cause confusion if you have lexicals used by multiple +subs where some are inside churn blocks and others are not, so best not to do +that. Package variables work a bit better, but any assignment lines are re-run. +So C<our $FOO;> is fine (it does not change the value if it is set) but +C<our $FOO = ...> will reset the var on each reload. + +=head1 EXPORTS + +=over 4 + +=item $meta = TEST2_HARNESS_PRELOAD() + +=item $meta = $class->TEST2_HARNESS_PRELOAD() + +This export provides the meta object, which is an instance of this class. This +method being present is how Test2::Harness differentiates between a regular +module and a special preload library. + +=item stage NAME => sub { ... } + +This creates a new stage with the given C<NAME>, and then runs the coderef with +the new stage set as the I<active> one upon which the other function here will +operate. Once the coderef returns the I<active> stage is cleared. + +You may nest stages by calling this function again inside the codeblock. + +B<NOTE:> stage names B<ARE> case sensitive. This can be confusing when you +consider that most harness directives are all-caps. In the following case the +stage requested by the test and the stage defined in +the library are NOT the same. + +In a test file: + + # HARNESS-STAGE-FOO + +In a preload library: + + stage foo { ... } + +Harness directives are all-caps, however the user data portion need not be, +this is fine: + + # HARNESS-STAGE-foo + +However it is very easy to make the mistake of thinking it is case insensitive. +It is also easy to assume the 'foo' part of the harness directive must be all +caps. In many cases it is smart to make your stage names all-caps. + +=item preload $module_name + +=item preload @module_names + +=item preload sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +This adds modules to the list of libraries to preload. Order is preserved. You +can also add coderefs to execute arbitrary code between module loads. + +The coderef is called with no arguments, and its return is ignored. + +=item eager() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This marks the I<active> stage as being I<eager>. An eager stage will start +running tests for nested stages if it finds itself with no tests of its own to +run before the nested stage can finish loading. The idea here is to avoid +unused test slots when possible allowing for tests to complete sooner. + +=item default() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This B<MUST> be called only once across C<ALL> stages in a given library. + +If multiple preload libraries are loaded then the I<first> default set (based +on load order) will be the default, others will notbe honored. + +=item $stage_name = file_stage($test_file) + +This is optional. If defined this callback will have a chance to look at all +files that are going to be run and assign them a stage. This may return undef +or an empty list if it does not have a stage to assign. + +If multiple preload libraries define file_stage callbacks they will be called +in order, the first one to return a stage name will win. + +If no file_stage callbacks provide a stage for a file then any harness +directives declaring a stage will be honored. If no stage is ever assigned then +the test will be run int he default stage. + +=item pre_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before the preload-stage process forks to run the +test. Note that any state changes here can effect future tests to be run. + +=item post_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just after the preload-stage process forks to run the +test. This is run as early as possible, things like C<$0> may not be set +properly yet. + +=item pre_launch sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before control of the test process is turned over +to the test file itself. This is run as late as possible, so things like C<$0> +should be set properly. + +=back + +=head1 META-OBJECT + +This class is also the meta-object used to construct a preload library. The +methods are left undocumented as this is an implementation detail and you are +not intended to directly use this object. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Preload/Stage.pm b/bad/Test2/Harness/Runner/Preload/Stage.pm new file mode 100644 index 000000000..abba7a828 --- /dev/null +++ b/bad/Test2/Harness/Runner/Preload/Stage.pm @@ -0,0 +1,159 @@ +package Test2::Harness::Runner::Preload::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <name + <frame + <children + <pre_fork_callbacks + <post_fork_callbacks + <pre_launch_callbacks + <load_sequence + <watches + eager + reload_remove_check + reload_inplace_check +}; + +sub init { + my $self = shift; + + $self->{+FRAME} //= [caller(1)]; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; + croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; + + $self->{+CHILDREN} //= []; + + $self->{+PRE_FORK_CALLBACKS} //= []; + $self->{+POST_FORK_CALLBACKS} //= []; + $self->{+PRE_LAUNCH_CALLBACKS} //= []; + + $self->{+LOAD_SEQUENCE} //= []; + $self->{+WATCHES} //= {}; +} + +sub watch { + my $self = shift; + my ($file, $callback) = @_; + croak "The first argument must be a file" unless $file && -f $file; + croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; + croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; + + $self->{+WATCHES}->{$file} = $callback; + return; +} + +sub all_children { + my $self = shift; + + my @out = @{$self->{+CHILDREN}}; + + for (my $i = 0; $i < @out; $i++) { + my $it = $out[$i]; + push @out => @{$it->children}; + } + + return \@out; +} + +sub add_child { + my $self = shift; + my ($stage) = @_; + push @{$self->{+CHILDREN}} => $stage; +} + +sub add_pre_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; +} + +sub add_post_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+POST_FORK_CALLBACKS}} => $cb; +} + +sub add_pre_launch_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; +} + +sub add_to_load_sequence { + my $self = shift; + + for my $item (@_) { + croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" + unless ref($item) eq 'CODE' || !ref($item); + + push @{$self->{+LOAD_SEQUENCE}} => $item; + } + + return @_; +} + +sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } +sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } +sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload::Stage - Abstraction of a preload stage. + +=head1 DESCRIPTION + +This is an implementation detail. You are not intended to directly use/modify +instances of this class. See L<Test2::Harness::Runner::Preload> for +documentation on how to write a custom preload library. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Preloader.pm b/bad/Test2/Harness/Runner/Preloader.pm new file mode 100644 index 000000000..24ced8fe8 --- /dev/null +++ b/bad/Test2/Harness/Runner/Preloader.pm @@ -0,0 +1,684 @@ +package Test2::Harness::Runner::Preloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use B(); +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use Time::HiRes qw/time sleep/; +use Test2::Harness::Util qw/open_file file2mod mod2file lock_file unlock_file clean_path/; + +use Test2::Harness::Runner::Reloader; +use Test2::Harness::Runner::Preloader::Stage; + +use File::Spec(); +use List::Util qw/pairgrep/; + +use Test2::Harness::Util::HashBase( + qw{ + <dir + <preloads + <done + <below_threshold + + <dtrace <reloader + + <staged <started_stages <stage + + <dump_depmap + <changed + <restrict_reload + + <blacklist_file + <blacklist_lock + <blacklist + + <monitored + <state + }, + + '<monitor', # This means watch for changes, restart stage if any found + '<reload', # Try to reload in place instead of restart stage +); + +sub init { + my $self = shift; + + croak "'state' is a required attribute" unless $self->{+STATE}; + + $self->{+PRELOADS} //= []; + + $self->{+BELOW_THRESHOLD} //= 0; + + return if $self->{+BELOW_THRESHOLD}; + + $self->{+MONITOR} = 1 if $self->{+RELOAD}; + + my $need_depmap = $self->{+RELOAD} || $self->{+MONITOR} || $self->{+DUMP_DEPMAP}; + + if ($need_depmap) { + require Test2::Harness::Runner::DepTracer; + $self->{+DTRACE} //= Test2::Harness::Runner::DepTracer->new(); + } + + if ($self->{+MONITOR} || $self->{+RELOAD}) { + $self->{+BLACKLIST} //= {}; + $self->{+BLACKLIST_FILE} //= File::Spec->catfile($self->{+DIR}, 'BLACKLIST'); + } + + $self->{+RELOADER} = Test2::Harness::Runner::Reloader->new( + stat_min_gap => 2, + notify_cb => sub { $self->_reload_cb_notify(@_) }, + find_loaded_cb => sub { $self->_reload_cb_find_loaded(@_) }, + should_watch_cb => sub { $self->_reload_cb_should_watch(@_) }, + can_reload_cb => sub { $self->_reload_cb_can_reload(@_) }, + reload_cb => sub { $self->_reload_cb_reload(@_) }, + delete_symbol_cb => sub { $self->_reload_cb_delete_symbol(@_) }, + ); +} + +sub stage_name { $_[0]->{+STAGE} ? $_[0]->{+STAGE}->name : 'default' } + +sub stage_check { + my $self = shift; + my ($stage) = @_; + + return 0 if $self->{+BELOW_THRESHOLD}; + + my $p = $self->{+STAGED} or return 0; + return 1 if $stage eq 'NOPRELOAD'; + return 1 if $p->stage_lookup->{$stage}; + return 0; +} + +sub task_stage { + my $self = shift; + my ($file, $wants) = @_; + + $wants //= ""; + + return 'default' if $self->{+BELOW_THRESHOLD}; + return 'default' unless $self->{+STAGED}; + + return $wants if $wants && $self->stage_check($wants); + + my $stage = $self->{+STAGED}->file_stage($file) // $self->{+STAGED}->default_stage; + + return $stage; +} + +sub preload { + my $self = shift; + + croak "Already preloaded" if $self->{+DONE}; + + return 'default' if $self->{+BELOW_THRESHOLD}; + + my $preloads = $self->{+PRELOADS} or return 'default'; + return 'default' unless @$preloads; + + require Test2::API; + Test2::API::test2_start_preload(); + + # Not loading blacklist yet because any preloads in this list need to + # happen regardless of the blacklist. + if ($self->{+MONITOR} || $self->{+DTRACE}) { + $self->_monitor_preload($preloads); + } + else { + $self->_preload($preloads); + } + + $self->state->touch_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); + + $self->{+DONE} = 1; +} + +sub preload_stages { + my $self = shift; + return 'default' unless $self->{+STAGED}; + return $self->_preload_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); +} + +sub _preload_stages { + my $self = shift; + my @stages = @_; + + my $name = 'base'; + my @procs; + + while (my $stage = shift @stages) { + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $proc = $self->launch_stage($stage); + + if ($proc) { + push @procs => $proc; + next; + } + + # We are in the stage now, reset these + if (ref $stage) { + $name = $stage->name; + @procs = (); + @stages = @{$stage->children}; + } + else { # NOPRELOAD + $name = $stage; + @procs = (); + @stages = (); + } + + $self->start_stage($stage); + } + + return($name, @procs); +} + +sub launch_stage { + my $self = shift; + my ($stage) = @_; + + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $name = ref($stage) ? $stage->name : $stage; + + my $pid = fork(); + + return Test2::Harness::Runner::Preloader::Stage->new( + pid => $pid, + name => $name, + ) if $pid; + + $0 .= "-$name"; + $ENV{T2_HARNESS_STAGE} = $name; + + return; +} + +sub start_stage { + my $self = shift; + my ($stage) = @_; + + if ($self->{+STAGED}) { + if ($stage && !ref($stage)) { + $stage = $self->{+STAGED}->stage_lookup->{$stage}; + } + } + else { + $stage = undef; + } + + $self->{+STAGE} = $stage; + + $self->load_blacklist if $self->{+MONITOR}; + + # Localize these in case something we preload tries to modify them. + local $SIG{INT} = $SIG{INT}; + local $SIG{HUP} = $SIG{HUP}; + local $SIG{TERM} = $SIG{TERM}; + + my $preloads = $stage ? $stage->load_sequence : []; + + my $meth = $self->{+MONITOR} || $self->{+DTRACE} ? '_monitor_preload' : '_preload'; + + $self->$meth($preloads, $stage->watches) if $preloads && @$preloads; + + $self->_monitor() if $self->{+MONITOR}; +} + +sub get_stage_callback { + my $self = shift; + my ($name) = @_; + + my $stage = $self->{+STAGE} or return undef; + return undef unless ref $stage; + return $stage->$name; +} + +sub _monitor_preload { + my $self = shift; + my ($preloads, $watch) = @_; + + my $block = {%{$self->blacklist}}; + my $dtrace = $self->dtrace; + + $dtrace->start; + $self->_preload($preloads, $block, $dtrace->my_require); + $dtrace->add_callbacks(%$watch) if $watch; + $dtrace->stop; + + return; +} + +sub _preload { + my $self = shift; + my ($preloads, $block, $require_sub) = @_; + + $block //= {}; + + my %seen; + for my $mod (@$preloads) { + next if $seen{$mod}++; + + if (ref($mod) eq 'CODE') { + next if eval { $mod->($block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + next; + } + + next if $block && $block->{$mod}; + + next if eval { $self->_preload_module($mod, $block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + } + + return; +} + +sub _preload_module { + my $self = shift; + my ($mod, $block, $require_sub) = @_; + + my $file = mod2file($mod); + + $require_sub ? $require_sub->($file) : require $file; + + return unless $mod->can('TEST2_HARNESS_PRELOAD'); + + die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; + + $self->{+STAGED} //= do { + require Test2::Harness::Runner::Preload; + Test2::Harness::Runner::Preload->new(); + }; + + $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); + + return; +} + +sub eager_stages { + my $self = shift; + + return unless $self->{+STAGED}; + return $self->{+STAGED}->eager_stages; +} + +sub load_blacklist { + my $self = shift; + + my $bfile = $self->{+BLACKLIST_FILE}; + my $blacklist = $self->{+BLACKLIST}; + + return unless -f $bfile; + + my $fh = open_file($bfile, '<'); + while(my $pkg = <$fh>) { + chomp($pkg); + $blacklist->{$pkg} = 1; + } +} + +sub _lock_blacklist { + my $self = shift; + + return $self->{+BLACKLIST_LOCK} if $self->{+BLACKLIST_LOCK}; + + my $bl = lock_file($self->{+BLACKLIST_FILE}, '>>'); + seek($bl,2,0); + + return $self->{+BLACKLIST_LOCK} = $bl; +} + +sub _unlock_blacklist { + my $self = shift; + + my $bl = delete $self->{+BLACKLIST_LOCK} or return; + + $bl->flush; + unlock_file($bl); + close($bl); + + return; +} + +sub _notify { + my $self = shift; + for my $msg (@_) { + print "$$ $0 - $msg\n"; + } +} + +sub _reload_cb_notify { + my $self = shift; + my ($type, $info) = @_; + + return $self->_notify("Runner detected a change in one or more preloaded modules...") + if $type eq 'changes_detected'; + + return $self->_notify("Runner detected changes in file '$info'...") + if $type eq 'file_changed'; + + return $self->_notify("Runner attempting to reload '$info->{file}' in place...") + if $type eq 'reload_inplace'; + + return $self->_notify( + "Runner failed to reload '$info->{file}' in place...", + map { split /\n/, $_ } grep { $_ } @{$info->{warnings} // []}, $info->{error}, + ) if $type eq 'reload_fail'; + + require Data::Dumper; + no warnings 'once'; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Maxdepth = 2; + return $self->_notify("Runner notification $type: " . (ref($info) ? Data::Dumper::Dumper($info) : $info) . "..."); +} + +sub _reload_cb_find_loaded { keys %{$_[0]->dtrace->loaded} } + +sub _reload_cb_should_watch { + my $self = shift; + my ($reloader, $rel, $abs) = @_; + + my $dirs = $self->{+RESTRICT_RELOAD}; + return 1 unless $dirs && @$dirs; + + for my $dir (@$dirs) { + return 1 if 0 == index($abs, $dir); + } + + return 0; +} + +sub _reload_cb_can_reload { + my $self = shift; + my %params = @_; + + my $mod = $params{module}; + my $file = $params{file}; + + return (0, reason => 'File is a yath preload module') if $mod->can('TEST2_HARNESS_PRELOAD'); + + if (my $cb = $self->get_stage_callback('reload_inplace_check')) { + my ($res, %fields) = $cb->(module => $mod, file => $file); + return ($res, %fields) if defined $res; + } + + return (1) unless $mod->can('import'); + + return (0, reason => 'File is an importer') if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT"}; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT_OK"}; + } + + return (1); +} + +sub find_churn { + my $self = shift; + my ($file) = @_; + + # When a file is saved to disk it seems it can vanish temporarily. Use this loop to wait for it... + my ($fh, $ok, $error); + for (1 .. 50) { + local $@; + $ok = eval { $fh = open_file($file) }; + $error = "LOOP $_: $@"; + last if $ok; + sleep 0.2; + } + + die $error // "Unknown error opening file '$file'" unless $fh; + + my $active = 0; + my @out; + + my $line_no = 0; + while (my $line = <$fh>) { + $line_no++; + + if ($active) { + if ($line =~ m/^\s*#\s*HARNESS-CHURN-STOP\s*$/) { + push @{$out[-1]} => $line_no; + $active = 0; + next; + } + else { + $out[-1][-1] .= $line; + next; + } + } + + if ($line =~ m/^\s*#\s*HARNESS-CHURN-START\s*$/) { + $active = 1; + push @out => [$line_no, '']; + } + } + + return @out; +} + +sub _reload_cb_reload { + my $self = shift; + my %params = @_; + + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my $callbacks; + if (my $dtrace = $self->dtrace) { + $callbacks = $dtrace->callbacks; + } + $callbacks //= {}; + + if (my $cb = $callbacks->{$file} // $callbacks->{$rel}) { + $self->_notify("Changed file '$rel' has a reload callback, executing it instead of regular reloading..."); + my $ret = $cb->(); + return (1, callback_return => $ret); + } + + if (my @churn = $self->find_churn($file)) { + $self->_notify("Changed file '$rel' contains churn sections, running them instead of a full reload..."); + + for my $churn (@churn) { + my ($start, $code, $end) = @$churn; + my $sline = $start + 1; + if (eval "package $mod;\nuse strict;\nuse warnings;\nno warnings 'redefine';\n#line $sline $file\n$code\n ;1;") { + $self->_notify("Success reloading churn block ($file lines $start -> $end)"); + } + else { + $self->_notify("Error reloading churn block ($file lines $start -> $end): $@"); + } + } + + return (1); + } + + return (0, reason => 'reloading disabled') unless $self->{+RELOAD}; + + return undef; +} + +sub _reload_cb_delete_symbol { + my $self = shift; + my %params = @_; + + my $sym = $params{symbol}; + my $mod = $params{module}; + my $file = $params{file}; + + # Make sure the changed file and the file that defined the sub are the same. + my $cb = $self->get_stage_callback('reload_remove_check') or return 0; + my $sub = $mod->can($sym) or return 0; + my $cobj = B::svref_2object($sub) or return 0; + my $subfile = $cobj->FILE or return 0; + + my $res = $cb->( + mod => $mod, + sym => $sym, + sub => $sub, + from_file => -f $subfile ? clean_path($subfile) : $subfile, + reload_file => -f $file ? clean_path($file) : $file, + ); + + # 0 means do not skip, so if the cb returned true we do not skip + return 0 if $res; + return 1; +} + +sub _monitor { + my $self = shift; + + if ($self->{+MONITORED} && $self->{+MONITORED}->[0] == $$) { + die "Monitor already starated\n" . "\n=======\n$0\n" . Carp::longmess() . "\n=====\n" . $self->{+MONITORED}->[1] . "\n" . $self->{+MONITORED}->[2] . "\n=======\n"; + } + + $self->{+MONITORED} = [$$, $0, Carp::longmess()]; + + my $reloader = $self->{+RELOADER}; + $reloader->reset(); + $reloader->refresh(); + + return $self->{+MONITORED}; +} + +sub check { + my $self = shift; + + return 1 if $self->{+CHANGED}; + + return 0 unless $self->{+MONITOR}; + + my $dtrace = $self->dtrace; + $dtrace->start if $self->{+RELOAD}; + + my $results = $self->{+RELOADER}->reload_changes(); + + $dtrace->stop if $self->{+RELOAD}; + + my (%update, @todo, @fails); + for my $item (values %$results) { + + my $file = $item->{file}; + my $success = $item->{reloaded}; + my $error = $item->{error}; + my $warnings = $item->{warnings}; + my $rel = $item->{reloaded}; + + my %fields; + $fields{error} = $error if defined($error) && length($error); + $fields{warnings} = $warnings if $warnings && @{$warnings}; + + $update{$file} = keys(%fields) ? \%fields : undef; + + next if $rel; # Reload success + + if (defined $rel) { # Not reloaded, but no error + push @todo => $item; + next; + } + } + + $self->state->stage_update_reload_result($self->stage_name, %update) + if keys %update; + + unless (@todo) { + $self->{+RELOADER}->refresh(); + return 0; + } + + $self->{+CHANGED} = 1; + $self->_notify("blacklisting changed files and reloading stage..."); + + my $bl = $self->_lock_blacklist(); + + my $dep_map = $self->dtrace->dep_map; + + my %CNI = reverse pairgrep { $b } %INC; + + my %seen; + while (@todo) { + my $item = shift @todo; + my $ref = ref($item); + + my ($mod, $abs, $rel); + if ($ref eq 'HASH') { + ($mod, $abs, $rel) = @{$item}{qw/module file relative/}; + } + elsif ($ref eq 'ARRAY') { + ($mod, $abs) = @$item; + $rel = $CNI{$abs} || $abs; + } + else { + die "Invalid ref type: $ref"; + } + + next if $seen{$abs}++; + next if $mod->can('TEST2_HARNESS_PRELOAD'); + $self->_notify("Blacklisting $mod..."); + print $bl "$mod\n"; + my $next = $dep_map->{$abs} or next; + push @todo => @$next; + } + + $self->_unlock_blacklist(); + + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader - Preload logic. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries before running tests. This +entire module is considered an "Implementation Detail". Please do not rely on +it always staying the same, or even existing in the future. Do not use this +directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/bad/Test2/Harness/Runner/Preloader/Stage.pm b/bad/Test2/Harness/Runner/Preloader/Stage.pm new file mode 100644 index 000000000..3559eabad --- /dev/null +++ b/bad/Test2/Harness/Runner/Preloader/Stage.pm @@ -0,0 +1,62 @@ +package Test2::Harness::Runner::Preloader::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase qw{ <name eager }; + +sub category { $_[0]->{+CATEGORY} //= 'stage' } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader::Stage - Representation of a persistent stage process. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries for a specific stage before +running tests. This entire module is considered an "Implementation Detail". +Please do not rely on it always staying the same, or even existing in the +future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Reloader.pm b/bad/Test2/Harness/Runner/Reloader.pm new file mode 100644 index 000000000..010a30727 --- /dev/null +++ b/bad/Test2/Harness/Runner/Reloader.pm @@ -0,0 +1,338 @@ +package Test2::Harness::Runner::Reloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/file2mod is_same_file/; + +use File::Spec(); + +BEGIN { + local $@; + my $inotify = eval { require Linux::Inotify2; 1 }; + if ($inotify) { + my $MASK = Linux::Inotify2::IN_MODIFY(); + $MASK |= Linux::Inotify2::IN_ATTRIB(); + $MASK |= Linux::Inotify2::IN_DELETE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + + *USE_INOTIFY = sub() { 1 }; + require constant; + constant->import(INOTIFY_MASK => $MASK); + } + else { + *USE_INOTIFY = sub() { 0 }; + *INOTIFY_MASK = sub() { 0 }; + } +} + +use Test2::Harness::Util::HashBase qw{ + <notify_cb <find_loaded_cb <should_watch_cb <can_reload_cb <reload_cb <delete_symbol_cb + <monitored <monitor_lookup + <watcher + <stat_min_gap <stat_last_checked + <pid +}; + +sub _pid_check { + my $self = shift; + + return 1 unless USE_INOTIFY; + + my $pid = $self->{+PID} //= $$; + + croak "PID has changed $$ vs $pid (Maybe you need to call reset()?)" + unless $$ == $pid; + + return 1; +} + +sub init { + my $self = shift; + $self->{+CAN_RELOAD_CB} //= $self->can('_can_reload'); + $self->{+FIND_LOADED_CB} //= $self->can('_find_loaded'); + $self->{+STAT_MIN_GAP} //= 2; + + $self->reset; +} + +sub reset { + my $self = shift; + delete $self->{+PID}; + $self->{+MONITORED} = {}; + $self->{+MONITOR_LOOKUP} = {}; + if (USE_INOTIFY) { + $self->{+WATCHER} = Linux::Inotify2->new; + $self->{+WATCHER}->blocking(0); + } else { + $self->{+WATCHER} = {}; + } + delete $self->{+STAT_LAST_CHECKED}; +} + +sub _find_loaded { keys %INC } + +sub refresh { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + my $cb = $self->{+FIND_LOADED_CB}; + for my $file ($self->$cb($monitored)) { + next if exists $monitored->{$file}; + $self->monitor($file); + } +} + +sub monitor { + my $self = shift; + my ($file) = @_; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + return if exists $monitored->{$file}; + + my $watch = $self->find_file_to_watch($file); + + return $monitored->{$file} = 0 unless $watch && -e $watch; + + if (my $should_watch_cb = $self->{+SHOULD_WATCH_CB}) { + return $monitored->{$file} = 0 unless $self->$should_watch_cb($file => $watch); + } + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($watch, INOTIFY_MASK()); + } + else { + my $stats = $self->{+WATCHER}; + $stats->{$watch} = $self->_get_file_times($watch); + } + + $self->{+MONITOR_LOOKUP}->{$watch} = $file; + $monitored->{$file} = $watch; + return $watch; +} + +sub find_file_to_watch { + my $self = shift; + my ($file) = @_; + + return $INC{$file} if $INC{$file} && -e $INC{$file}; + + for my $dir (@INC) { + next if ref($dir); + my $path = File::Spec->catfile($dir, $file); + return $path if -f $path; + } + + return $file if -e $file; +} + +sub _get_file_times { + my $self = shift; + my ($file) = @_; + my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); + return [$mtime, $ctime]; +} + +sub _get_changes { + my $self = shift; + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + my @todo = $inotify->read or return; + return {map { ($_->fullname() => 1) } @todo}; + } + + # Do not hammer the disk getting stat + my $check_time = time; + my $gap = $self->{+STAT_MIN_GAP}; + my $last_checked = $self->{+STAT_LAST_CHECKED}; + return if $last_checked && $gap && $gap > ($check_time - $last_checked); + $last_checked = $check_time; + + my $found = 0; + my $changed = {}; + my $stats = $self->{+WATCHER}; + for my $file (keys %$stats) { + my $old_times = $stats->{$file}; + my $new_times = $self->_get_file_times($file); + + # Compare times + next if $old_times->[0] == $new_times->[0] && $old_times->[1] == $new_times->[1]; + + # Update in case we choose not to reload + $stats->{$file} = $new_times; + + $found++; + $changed->{$file} = 1; + } + + return unless $found; + return $changed; +} + +sub _can_reload { + my %params = @_; + + my $mod = $params{module}; + + return 1 unless $mod->can('import'); + + return 0 if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return 0 if @{"$mod\::EXPORT"}; + return 0 if @{"$mod\::EXPORT_OK"}; + } + + return 1; +} + +sub reload_changes { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + $self->refresh(); + + my $changed = $self->_get_changes() or return; + + my $notify_cb = $self->{+NOTIFY_CB}; + + $notify_cb->(changes_detected => [keys %$changed]) if $notify_cb; + + my %out; + for my $file (sort keys %$changed) { + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($file, INOTIFY_MASK()); + } + + $notify_cb->(file_changed => $file) if $notify_cb; + + my $rel = $self->{+MONITOR_LOOKUP}->{$file}; + my $mod = file2mod($rel); + my %params = (reloader => $self, file => $file, relative => $rel, module => $mod, notify_cb => $notify_cb); + + my ($status, %fields) = $self->_reload_file(%params); + + $out{$file} = { + file => $file, + relative => $rel, + module => $mod, + reloaded => $status, + %fields, + }; + } + + return \%out; +} + +sub _reload_file { + my $self = shift; + my %params = @_; + + if (my $reload_cb = $self->{+RELOAD_CB}) { + my ($status, %fields) = $reload_cb->(%params); + return ($status, %fields) if defined $status; + } + + if (my $can_reload_cb = $self->{+CAN_RELOAD_CB}) { + my ($can, %fields) = $can_reload_cb->(%params); + return ($can, %fields) unless $can; + } + + my $notify_cb = delete $params{notify_cb}; + $notify_cb->(reload_inplace => \%params) if $notify_cb; + + my $del_cb = $self->{+DELETE_SYMBOL_CB}; + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my @warnings; + my $ok = eval { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + + my $stash = do { no strict 'refs'; \%{"${mod}\::"} }; + for my $sym (keys %$stash) { + next if $sym =~ m/::$/; + + next if $del_cb && $del_cb->(%params, symbol => $sym, stash => $stash); + + delete $stash->{$sym}; + } + + delete $INC{$rel}; + local $.; + require $rel; + die "Reloading '$rel' loaded '$INC{$rel}' instead of '$file', \@INC must have been altered" + unless is_same_file($file, $INC{$rel}); + + 1; + }; + my $err = $@; + + return (1) if $ok && !@warnings; + + $notify_cb->(reload_fail => {%params, warnings => \@warnings, error => $err}) if $notify_cb; + + return (undef, error => $err, warnings => \@warnings); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Reloader - reload logic. + +=head1 DESCRIPTION + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/bad/Test2/Harness/Runner/Resource.pm b/bad/Test2/Harness/Runner/Resource.pm new file mode 100644 index 000000000..81455162a --- /dev/null +++ b/bad/Test2/Harness/Runner/Resource.pm @@ -0,0 +1,597 @@ +package Test2::Harness::Runner::Resource; +use strict; +use warnings; + +use Term::Table; +use Time::HiRes qw/time/; +use Test2::Util::Times qw/render_duration/; + +our $VERSION = '1.000152'; + +sub scope_global { 0 } +sub scope_host { 0 } +sub scope_run { 1 } + +sub setup {} + +sub new { + my $class = shift; + return bless({@_}, $class); +} + +sub tick { } + +sub refresh { } + +sub discharge { } + +sub sort_weight { + my $class = shift; + return 100 if $class->job_limiter; + return 50; +} + +sub job_limiter { 0 } + +sub job_limiter_max { } + +sub job_limiter_at_max { 0 } + +sub available { -1 } + +sub record { } + +sub assign { } + +sub release { } + +sub cleanup { } + +sub status_data {()} + +sub status_lines { + my $self = shift; + + my $data = $self->status_data || return; + return unless @$data; + + my $out = ""; + + for my $group (@$data) { + my $gout = "\n"; + $gout .= "**** $group->{title} ****\n\n" if defined $group->{title}; + + for my $table (@{$group->{tables} || []}) { + my $rows = $table->{rows}; + + if (my $format = $table->{format}) { + my $rows2 = []; + + for my $row (@$rows) { + my $row2 = []; + for (my $i = 0; $i < @$row; $i++) { + my $val = $row->[$i]; + my $fmt = $format->[$i]; + + $val = defined($val) ? render_duration($val) : '--' + if $fmt && $fmt eq 'duration'; + + push @$row2 => $val; + } + push @$rows2 => $row2; + } + + $rows = $rows2; + } + + next unless $rows && @$rows; + + my $tt = Term::Table->new( + header => $table->{header}, + rows => $rows, + + sanitize => 1, + collapse => 1, + auto_columns => 1, + + %{$table->{term_table_opts} || {}}, + ); + + $gout .= "** $table->{title} **\n" if defined $table->{title}; + $gout .= "$_\n" for $tt->render; + $gout .= "\n"; + } + + if ($group->{lines} && @{$group->{lines}}) { + $gout .= "$_\n" for @{$group->{lines}}; + $gout .= "\n"; + } + + $out .= $gout; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource - Base class for resource management classes + +=head1 DESCRIPTION + +Sometimes you have limited resources that must be shared/divided between tests +that run concurrently. Resource classes give you a way to leverage the IPC +system used by L<Test2::Harness> to manage resource assignment and recovery. + +=head1 SYNOPSIS + +Here is a resource class that simply assigns an integer to each test. It would +be possible to re-use integers, but since there are infinite integers this +example is kept simple and just always grabs the next one. + + package Test2::Harness::Runner::Resource::Foo; + use strict; + use warnings; + + use parent 'Test2::Harness::Runner::Resource'; + + sub setup { + my $class = shift; # NOT AN INSTANCE + ... + } + + sub available { + my $self = shift; + my ($task) = @_; + + # There are an infinite amount of integers, so we always return true + return 1; + } + + sub assign { + my $self = shift; + my ($task, $state) = @_; + + # Next ID, do not record the state change yet! + my $id = 1 + ($self->{ID} //= 0); + + print "ASSIGN: $id = $task->{job_id}\n"; + + # 'record' should get whatever we need to record the resource, whatever you + # pass in will become the argument to the record() sub below. This may be a + # scalar, a hash, an array, etc. It will be serialized to JSON before + # record() sees it. + $state->{record} = $id; + + # Pass the resource into the test, this can be done as envronment variables + # and/or arguments to the test (@ARGV). + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + + # The return is ignored. + return; + } + + sub record { + my $self = shift; + my ($job_id, $record_arg_from_assign) = @_; + + # The ID from $state->{record}->{$pkg} in assign. + my $id = $record_arg_from_assign; + + # Update our internal state to reflect the new ID. + $self->{ID} = $id; + + # Add a mapping of what job ID gets what integer ID. + $self->{ID_TO_JOB_ID}->{$id} = $job_id; + $self->{JOB_ID_TO_ID}->{$job_id} = $id; + + print "RECORD: $id = $job_id\n"; + + # The return is ignored + } + + sub tick { + my $self = shift; + + # This is called by only 1 process at a time and gives you a way to do + # extra stuff at a regular interval without other processes trying to + # do the same work at the same time. + # For example, if a database is left in a dirty state after it is + # released, you can fire off a cleanup action here knowing no other + # process will run it at the same time. You can also be sure no record + # messages will be sent while this sub is running as the process it + # runs in has a lock. + + ... + } + + + sub release { + my $self = shift; + my ($job_id) = @_; + + # Clear the internal mapping, the integer ID is now free. Theoretically it + # can be reused, but this example is not that complex. + my $id = delete $self->{JOB_ID_TO_ID}->{$job_id}; + + # This is called for all tests that complete, even if they did not use + # this resource, so we return if the job_id is not applicable. + return unless defined $id; + + delete $self->{ID_TO_JOB_ID}->{$id}; + + print " FREE: $id = $job_id\n"; + + # The return is ignored + } + + sub cleanup { + my $self = shift; + + print "CLEANUP!\n"; + } + + 1; + +The print statements generated will look like this when running 2 tests concurrently: + + yath test -R Foo -j2 t/testA.t t/testB.t + [...] + (INTERNAL) ASSIGN: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) RECORD: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) ASSIGN: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) RECORD: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) FREE: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) FREE: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) CLEANUP! + [...] + +Depending on the tests run the 'FREE' prints may be out of order. + +=head1 WORKFLOW + +=head2 HOW STATE IS MANAGED + +Depending on your preload configuration, yath may have several runners +launching tests. If a runner has nothing to do it will lock the queue and try +to find the next test that should be run. Only 1 of the runners will be in +control of the queue at any given time, but the control of the queue may pass +between runners. To manage this there is a mechanism to record messages that +allow each runner to maintain a copy of the current state. + +=head2 CHECK IF RESOURCES ARE AVAILABLE + +Each runner will have an instance of your resource class. When the runner is in +control of the queue, and wants to designate the next test to run, it will +check with the resource classes to make sure the correct resources are +available. To do that it will call C<available($task)> on each resource +instance. + +The C<$task> will contain the specification for the test, it is a hashref, and +you B<SHOULD NOT> modify it. The only key most people care about is the 'file' +key, which has the test file that will be run if resources are available. + +If resources are available, or if the specific file does not need the resource, +the C<available()> method should return true. If the file does need your +resource(s), and none are available, this should return false. If any resource +class returns false it means the test cannot be run yet and the runner will +look for another test to run. + +=head2 ASSIGN A RESOURCE + +If the runner has determined the test can be run, and all necessary resources +are available, it will then call C<assign($task, $state)> on all resource class +instances. At this time the resource class should decide what resource(s) to +assign to the class. + +B<CRITICAL NOTE:> the C<assing()> method B<MUST NOT> alter any internal state +on the resource class instance. State modification must wait for the +C<record()> method to be called. This is because the C<assign()> method is only +called in one runner process, the C<record()> method call will happen in every +runner process to insure they all have the same internal state. + +The assign() sub should modify the C<$state> hash, which has 3 keys: + +=over 4 + +=item env_vars => {} + +Env vars to set for the test + +=item args => [] + +Arguments to pass to the test + +=item record => ... + +Data needed to record the state change for resource classes. Can be a scalar, +hashref, arrayref, etc. It will be serialized to JSON to be passed between +processes. + +=back + +=head2 RECORD A RESOURCE + +Once a resource is assigned, a message will be sent to all runner processes +B<INCLUDING THE ONE THAT DID THE ASSIGN> that says it should call +C<record($job_id, $record_val)> on your resource class instance. Your resource +class instance must use this to update the state so that once done ALL +processes will have the proper internal state. + +The C<$record_val> is whatever you put into C<< $state->{record} >> in the +C<assign()> method above. + +=head2 QUEUE MANAGEMENT IS UNLOCKED + +Once the above has been done, queue management will be unlocked. You can be +guarenteed that only one process will be run the C<available()>, and +C<assign()> sequence at a time, and that they will be called in order, though +C<assign()> may not be called if another resource was not available. If +C<assign()> is called, you can be guarenteed that all processes, including the +one that called C<assign()> will have their C<record()> called with the proper +argument B<BEFORE> they try to manage the queue (which is the only place +resources are checked or assigned). + +=head2 RELEASE A RESOURCE + +Whenever a process that is using a resource exits, the runner that waits on +that process will I<eventually> send an IPC message announcing that the job_id +has completed. Every time a job_id completes the C<release($job_id)> method +will be called on your resource class in all runner processes. This allows the +state to be updated to reflect the freed resource. + +You can be guarenteed that any process that locks the queue to run a new +test will eventually see the message. The message may come in during a loop +that is checking for resources, in which case the state will not reflect the +resource being available, however in such cases the loop will end and be +called again later with the message having been receieved. There will be no +deadlock due to a queue manager waiting for the message. + +There are no guarentees about what order resources will be released in. + +=head1 METHODS + +=over 4 + +=item $class->setup($settings) + +This will be called once before the runner forks or initialized per-process +instances. If you have any "setup once" tasks to initialize resources before +tests run this is a good place to do it. + +This runs immedietly after plugin setup() methods are called. + +B<NOTE:> Do not rely on recording any global state here, the runner and +per-process instances may not be forked from the process that calls setup(). + +=item $res = $class->new(settings => $settings); + +A default new method, returns a blessed hashref with the settings key set to +the L<Test2::Harness::Settings> instance. + +=item $val = $res->available(\%task) + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +B<DO NOT MODIFY THE TASK HASHREF> + +Returns a positive true value if the resource is available. + +Returns false if the resource is not available, but will be in the future (IE +in use by another test, but will be free when that test is done). + +Returns a negative value if the resource is not available and never will be. +This will cause any tests dependent on the resource to be skipped. + +The only key in C<\%task> hashref that most resources will care about is the +C<'file'> key, which contains the test file to be run. + +=item $res->assign(\%task, \%state) + +B<DO NOT MODIFY THE TASK HASHREF> + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +If the task does not need any resources you may simply return. + +If resources are needed you should deduce what resources to assign. + +You should put any data needed to update the internal state of your resource +instance in the C<< $state->{record} >> hash key. It B<WILL> be serialized to +JSON before being used as an argument to C<record()>. + + $state->{record} = $id; + +If you do not set the 'record' key, or set it to undef, then the C<record()> +method will not be called. + +If your tests need to know what resources to use, you may set environment +variables and/or command line arguments to pass into the test (C<@ARGV>). + + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + +The C<\%state> hashref is used only by your instance, you are free to fully +replace the 'env_vars' and 'args' keys. They will eventually be merged into a +master state along with those of other resources, but this ref is exclusive to +you in this method. + +=item $inst->record($job_id, $record_arg_from_assign) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called in all processes so that your instance can update any +internal state. + +The C<$job_id> variable contains the id for the job to which the resource was +assigned. You should use this to record any internal state. The $job_id will be +passed to C<release()> when the job completes and no longer needs the resource. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example creating a database should not be +done here, multiple processes will fight to do the create. The creation, if +necessary should be done in C<assign()> which will be called in only one +process. + +=item $inst->release($job_id) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called for every test job that completes, even if it did not use +this resource. If the job_id did not use the resource you may simply return, +otherwise update the internal state to reflect that the resource is no longer +in use. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example deleting a database should not be +done here, multiple processes will fight to do the delete. C<assign()> is the +only method that will be run in a single process, so if a database needs to be +cleaned before it can be used you should clean it there. Any final cleanup +should be done in C<cleanup()> which will only be called by one process at the +very end. + +=item $inst->cleanup() + +This will be called once by the parent runner process just before it exits. +This is your chance to do any final cleanup tasks such as deleting databases +that are no longer going to be used by tests as no more will be run. + +=item $inst->tick() + +This is called by only 1 process at a time and gives you a way to do extra +stuff at a regular interval without other processes trying to do the same work +at the same time. + +For example, if a database is left in a dirty state after it is released, you +can fire off a cleanup action here knowing no other process will run it at the +same time. You can also be sure no record messages will be sent while this sub +is running as the process it runs in has a lock. + +=item $inst->refresh() + +Called once before each resource-request loop. This is your chance to do things +between each set of requests for resources. + +=item $bool = $inst->job_limiter() + +True if your resource is intended as a job limiter (IE alternative to +specifying -jN at the command line). + +=item $int = $inst->job_limiter_max() + +Max number of jobs this will allow at the moment, if this resource is a job +limiter. + +=item $bool = $inst->job_limiter_at_max() + +True if the limiter has reached its maximum number of running jobs. This is +used to avoid a resource-allocation loop as an optimization. + +=item $number = $inst->sort_weight() + +Used to sort resources if you want them to be checked in a specific order. For +most resources this defaults to 50. For job_limiter resources this defaults to +100. Lower numbers are sorted to the front of the list, IE they are aquired +first, before other resources. + +Job slots are sorted later (100) so that we do not try to grab a job slot if +other resources are not available. + +Most of the time order will not matter, however with Shared job slots we have a +race with other test runs to get slots, and checking availability is enough to +consume a slot, even if other resources are not available. + +=item $string = $inst->status_lines() + +Get a (multi-line) string with status info for this resource. This is used to +populate the output for the C<yath resources> command. + +The default implementation will build a string from the data provided by the +C<status_data()> method. + +=item $arrayref = $inst->status_data() + +The default implementation returns an empty list. + +This should return status data that looks like this: + + return [ + { + title => "Resource Group Title", + tables => [ + { + header => \@columns, + rows => [ + \@row1, + \@row2, + ], + + # Optional fields + ################## + + # formatting for fields in rows + format => [undef, undef, 'duration', ...], + + # Title for the table + title => "Table Title", + + # Options to pass to Term::Table if/when it the data is used in Term::Table + term_table_opts => {...}, + }, + + # Any number of tables is ok + {...}, + ], + }, + + # Any number of groups is ok + {...}, + ]; + +Currently the only supported formats are 'default' (undef), and 'duration'. +Duration takes a stamp and tells you how much time has passed since the stamp. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Resource/JobCount.pm b/bad/Test2/Harness/Runner/Resource/JobCount.pm new file mode 100644 index 000000000..1c8fb3f6d --- /dev/null +++ b/bad/Test2/Harness/Runner/Resource/JobCount.pm @@ -0,0 +1,168 @@ +package Test2::Harness::Runner::Resource::JobCount; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw/<settings <job_count <used <free/; +use Time::HiRes qw/time/; +use List::Util qw/min/; + +sub job_limiter { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + $self->{+JOB_COUNT} //= $settings ? $settings->runner->job_count // 1 : 1; + $self->{+USED} //= {}; + $self->{+FREE} //= [1 .. $self->{+JOB_COUNT}]; +} + +sub job_limiter_max { + my $self = shift; + return $self->{+JOB_COUNT}; +} + +sub job_limiter_at_max { + my $self = shift; + return 0 if @{$self->{+FREE}}; + return 1; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + return -1 if $self->{+JOB_COUNT} < $tmin; + return -1 if $rmin < $tmin; + + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + return 1 if @{$self->{+FREE}} >= $concurrency; + return 0; +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + $state->{record} = { + count => $concurrency, + file => $task->{rel_file}, + stamp => time, + }; + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $concurrency; +} + +sub record { + my $self = shift; + my ($job_id, $info) = @_; + + my $count = $info->{count}; + my @use = splice @{$self->{+FREE}}, 0, $count; + $info->{slots} = \@use; + + $self->{+USED}->{$job_id} = $info; +} + +sub release { + my $self = shift; + my ($job_id) = @_; + + # Could be a free with no used slot. + my $info = delete $self->{+USED}->{$job_id} or return; + my $slots = $info->{slots}; + + push @{$self->{+FREE}} => @$slots; +} + +sub status_data { + my $self = shift; + + my @rows; + + my $time = time; + + for my $info (sort { $a->{stamp} <=> $b->{stamp} } values %{$self->{+USED}}) { + my $count = @{$info->{slots} || []}; + push @rows => [$time - $info->{stamp}, $count, $info->{file}]; + } + + push @rows => [undef, scalar(@{$self->{+FREE}}), '** FREE **']; + + return [ + { + tables => [ + { + headers => [qw/Runtime Slots Name/], + format => ['duration'], + rows => \@rows, + }, + ], + }, + ], +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::JobCount - limit the job count (-j) + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Resource/SharedJobSlots.pm b/bad/Test2/Harness/Runner/Resource/SharedJobSlots.pm new file mode 100644 index 000000000..7651f90f2 --- /dev/null +++ b/bad/Test2/Harness/Runner/Resource/SharedJobSlots.pm @@ -0,0 +1,439 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Test2::Harness::Runner::Resource::SharedJobSlots::State; +use Test2::Harness::Runner::Resource::SharedJobSlots::Config; + +use Time::HiRes qw/time/; +use List::Util qw/min/; +use Carp qw/confess/; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw{ + <settings + <state + <config + <runner_id + <runner_pid + <job_limiter_max + <observe +}; + +sub job_limiter { 1 } + +sub scope_host { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + die "Could not find shared jobs config.\n" + unless $sconf; + + my $access_id = $self->{+RUNNER_ID} //= $settings->runner->runner_id if $settings->check_prefix('runner'); + my $access_pid = $self->{+RUNNER_PID} //= $Test2::Harness::Runner::RUNNER_PID // $App::Yath::Command::runner::RUNNER_PID; + + my $prefix = $settings->debug->procname_prefix // ''; + my $name = $settings->harness->project // ''; + + my $dir; + if (my $path = $settings->harness->config_file) { + if ($path =~ m{^(.*)/[^/]+$}) { + $dir = $1; + } + } + + $dir //= $settings->harness->cwd; + + unless ($name) { + $name = $dir; + $name =~ s{^.*/}{}; + } + + $name = "$prefix-$name" if $prefix; + + $self->{+JOB_LIMITER_MAX} = min(grep { $_ } $sconf->max_slots_per_run, $settings->runner->job_count); + + $self->{+STATE} = Test2::Harness::Runner::Resource::SharedJobSlots::State->new( + state_umask => $sconf->state_umask, + state_file => $sconf->state_file, + access_id => $access_id, + access_pid => $access_pid, + access_meta => { + dir => $dir, + name => $name, + runner_id => $access_id, + runner_pid => $access_pid, + }, + + algorithm => $sconf->algorithm, + max_slots => $sconf->max_slots, + max_slots_per_job => $sconf->max_slots_per_job, + max_slots_per_run => $sconf->max_slots_per_run, + min_slots_per_run => $sconf->min_slots_per_run, + default_slots_per_run => $sconf->default_slots_per_run, + default_slots_per_job => $sconf->default_slots_per_job, + + my_max_slots => min($self->settings->runner->job_count, $sconf->max_slots), + my_max_slots_per_job => min($self->settings->runner->slots_per_job, $sconf->max_slots_per_job), + ); + + $self->{+CONFIG} = $sconf; + + return; +} + +# Disable this short-circuit otherwise we may never queue a request! +sub job_limiter_at_max { 0 } + +sub refresh { $_[0]->{+STATE}->update_registration } + +sub _job_concurrency { + my $self = shift; + my ($task) = @_; + + my $rmax = $self->settings->runner->job_count; + my $jmax = $self->settings->runner->slots_per_job; + my $srmax = $self->{+CONFIG}->max_slots_per_run; + my $sjmax = $self->{+CONFIG}->max_slots_per_job; + + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + my $max = min($tmax, $sjmax, $srmax, $jmax, $rmax); + + # Invalid condition, minimum is more than our maximim + return if $tmin > $max; + $max = $tmin if $max < $tmin; + + return [$tmin, $max]; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $con = $self->_job_concurrency($task); + return -1 unless $con; + + my $granted = $self->{+STATE}->allocate_slots(con => $con, job_id => $task->{job_id}); + + return unless $granted; + + return $granted +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + return if $self->{+OBSERVE}; + + my $info = $self->{+STATE}->assign_slots( + job => { + job_id => $task->{job_id}, + file => $task->{rel_file} // $task->{file} // $task->{job_name}, + }, + ); + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $info->{count}; + + return $info; +} + +sub record { } # NOOP + +sub release { + my $self = shift; + my ($job_id) = @_; + + return if $self->{+OBSERVE}; + + $self->{+STATE}->release_slots(job_id => $job_id); + + return; +} + +sub status_data { + my $self = shift; + + my @groups; + + my $state = $self->state->state; + my $runners = $state->{runners}; + my $access = $state->{access}; + + my $global_status = { + todo => 0, + allotted => 0, + assigned => 0, + pending => 0, + }; + + my $time = time; + + for my $runner (sort { $a->{added} <=> $b->{added} } values %$runners) { + my $run_status = { + todo => $runner->{todo}, + allotted => $runner->{allotment}, + assigned => 0, + pending => 0, + }; + + my $job_table = { + header => [qw/Runtime Slots Name/], + format => ['duration', undef, undef], + rows => [], + }; + + for my $job (sort { $a->{started} <=> $b->{started} } values %{$runner->{assigned}}) { + $run_status->{assigned} += $job->{count}; + my $stamp = $job->{started}; + my $slots = $job->{count}; + + push @{$job_table->{rows}} => [$time - $stamp, $slots, $job->{file} // $job->{job_id}]; + } + + $run_status->{pending} = $runner->{allotment} - $run_status->{assigned}; + + $global_status->{$_} += $run_status->{$_} for keys %$global_status; + + my $run_table = { + header => [qw/Todo Allotted Assigned Pending/], + rows => [[$run_status->{todo}, $run_status->{allotted}, $run_status->{assigned}, $run_status->{pending}]], + }; + + my $acc = $access->{$runner->{runner_id}}; + push @groups => { + title => "$acc->{user} - $acc->{name} - $acc->{access_id}", + tables => [ + $run_table, + $job_table, + ], + }; + } + + $global_status->{total} = $self->state->{max_slots}; + $global_status->{free} = $global_status->{total} - ($global_status->{assigned} + $global_status->{pending}); + $global_status->{free} = "$global_status->{free} (Minimum per-run overrides max slot count in some cases)" if $global_status->{free} < 0; + + unshift @groups => { + title => 'System Wide Summary', + tables => [ + { + header => ['Todo', 'Total Shared Slots', 'Allotted Shared Slots', 'Assigned Shared Slots', 'Pending Shared Slots', 'Free Shared Slots'], + rows => [[ @{$global_status}{qw/todo total allotted assigned pending free/} ]], + } + ], + }; + + return \@groups; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots - limit the job count (-j) per machine + +=head1 SYNOPSIS + +B<This synopsis is not about using this in code, but rather how to use it on the command line.> + +In order to use SharedJobSlots you must ether create the C<.sharedjobslots.yml> +file, or provide the C<--shared-jobs-config PATH> argument on the command line. +The C<PATH> must be a path to a yaml file with configuration specifications for +job sharing. + +=head1 CONFIG FILE + +Config files for shared slots must be yaml file, they must also be parsable by +L<YAML::Tiny>, which implements a subset of yaml. + +Here is an example config file: + + --- + DEFAULT: + state_file: /tmp/yath-slot-state + max_slots: 8 + max_slots_per_job: 2 + max_slots_per_run: 6 + + myhostname: + state_file: /tmp/myhostname-slot-state + max_slots: 16 + max_slots_per_job: 4 + max_slots_per_run: 12 + +=head2 TOP LEVEL KEYS (HOSTNAMES) + +All top level keys are hostnames. When the config is read the settings for the +current hostname will be used. If the hostname is not defined then the +C<DEFAULT> host will be read. If there is no C<DEFAULT> host defined an +exception will be thrown. + +=head2 CONFIG OPTIONS + +Each option must be specified under a hostname, none of these are valid on +their own. + +=over 4 + +=item state_file: /path/to/shared/state/file + +B<REQUIRED> + +This specifies the path to the shared state file. All yath processes by all +users who are sharing slots need read+write access to this file. + +=item state_umask: 0007 + +Defaults to C<0007>. Used to set the umask of the state file as well as the +lock file. + +=item max_slots: 8 + +Max slots system-wide for all users to share. + +=item max_slots_per_run: 4 + +Max slots a specific test run can use. + +=item min_slots_per_run: 0 + +Minimum slots per run. + +Set this if you want to make sure that all runs get at least N slots, +B<EVEN IF IT MEANS GOING OVER THE SYSTEM-WIDE MAXIMUM!>. + +This defaults to 0. + +=item max_slots_per_job: 2 + +Max slots a specific test job (test file) can use. + +=item default_slots_per_run: 4 + +If the user does not specify a number of slots, use this as the default. + +=item default_slots_per_job: 2 + +If the user does not specify a number of job slots, use this as the default. + +=item algorithm: fair + +=item algorithm: first + +=item algorithm: Fully::Qualified::Module::function_name + +Algorithm to use when assigning slots. 'fair' is the default. + +=back + +=head3 ALGORITHMS + +These are algorithms that are used to decide which test runs get which slots. + +=over 4 + +=item fair + +B<DEFAULT> + +This algorithm tries to balance slots so that all runs share an equal fraction +of available slots. If there are not enough slots to go around then priority +goes to oldest runs, followed by oldest requests. + +=item first + +Priority goes to the oldest run, followed by the next oldest, etc. If the run +age is not sufficient to sort requests this will fall back to 'fair'. + +This is mainly useful for CI systems or batched test boxes. This will give +priority to the first test run started, so additional test runs will not +consume slots the first run wants to use, but if the first run is winding down +and does not need all the slots, the second test run can start using only the +spare slots. + +Use this with ordered test runs where you do not want a purely serial run +order. + +=item Fully::Qualified::Module::function_name + +You can specify custom algorithms by giving fully qualified subroutine names. + +=back + +Example custom algorithm: + + sub custom_sort { + my ($state_object, $state_data, $a, $b) = @_; + + return 1 if a_should_come_first($a, $b); + return -1 if b_should_come_first($a, $b); + return 0 if both_have_same_priority($a, $b); + + # *shrug* + return 0; + } + +Ultimately this is used in a C<sort()> call, usual rules apply, return should +be 1, 0, or -1. $a and $b are the 2 items being compared. $state_object is an +instance of C<Test2::Harness::Runner::Resource::SharedJobSlots::State>. +$state_data is a hashref like you get from C<< $state_object->state() >> which +is useful if you want to know how many slots each runner is using for a 'fair' +style algorth. + +Take a look at the C<request_sort_XXX> methods on +C<Test2::Harness::Runner::Resource::SharedJobSlots::State> which implement the +3 original sorting methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm b/bad/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm new file mode 100644 index 000000000..353c6761c --- /dev/null +++ b/bad/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm @@ -0,0 +1,178 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::Config; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Sys::Hostname qw/hostname/; +use App::Yath::Util qw/find_in_updir/; + +use Test2::Harness::Util::HashBase qw{ + <config_file + <config_raw + + <host + + <common_conf + <host_conf + + +state_file + +state_umask + +algorithm + +max_slots + +max_slots_per_job + +max_slots_per_run + +min_slots_per_run + +default_slots_per_job + +default_slots_per_run +}; + +sub find { + my $class = shift; + my (%opts) = @_; + + my $base_name = delete $opts{base_name}; + my $settings = delete $opts{settings}; + my $config_file = delete $opts{config_file}; + + unless ($config_file) { + $base_name //= ($settings && $settings->check_prefix('runner')) ? $settings->runner->shared_jobs_config : '.sharedjobslots.yml'; + $config_file = ($base_name =~ m{(/|\\)} || -e $base_name) ? $base_name : find_in_updir($base_name); + } + + return unless $config_file && -e $config_file; + + return $class->new(%opts, config_file => $config_file); +} + +sub init { + my $self = shift; + + my $config_file = $self->{+CONFIG_FILE}; + + my $config = YAML::Tiny->read($config_file) or die "Could not read '$config_file'"; + $config = $self->{+CONFIG_RAW} = $config->[0]; # First doc only + + my $host = $self->{+HOST} //= hostname(); + + # Normalize an empty host config section to a hashref + $config->{$host} ||= {} if exists $config->{$host}; + + unless ($self->{+HOST_CONF} = $config->{$host}) { + if ($self->{+HOST_CONF} = $config->{DEFAULT}) { + $self->{+HOST} = 'DEFAULT'; + } + else { + die "Could not find '$host' or 'DEFAULT' settings in '$config_file'.\n"; + } + + warn <<" EOT" unless $self->{+HOST_CONF}->{no_warning}; +Using the 'DEFAULT' shared-slots host config. +You may want to add the current host to the config file. +To silence this warning, set the 'no_warning' key to true in the DEFAULT host config. + Config File: $config_file +Current Host: $host + EOT + } + + if ($self->{+HOST_CONF}->{use_common} //= 1) { + $self->{+COMMON_CONF} = $config->{'COMMON'} // {}; + } + + $self->{+COMMON_CONF} //= {}; + + #sanity check + $self->max_slots; + + return; +} + +sub state_umask { $_[0]->{+STATE_UMASK} //= $_[0]->_get_config_option(+STATE_UMASK, default => 0007) } +sub state_file { $_[0]->{+STATE_FILE} //= $_[0]->_get_config_option(+STATE_FILE, require => 1) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_get_config_option(+MAX_SLOTS, required => 1) } +sub min_slots_per_run { $_[0]->{+MIN_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MIN_SLOTS_PER_RUN, default => 0) } +sub max_slots_per_job { $_[0]->{+MAX_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_JOB, default => $_[0]->max_slots) } +sub max_slots_per_run { $_[0]->{+MAX_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_RUN, default => $_[0]->max_slots) } +sub default_slots_per_job { $_[0]->{+DEFAULT_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_JOB, default => $_[0]->max_slots_per_job) } +sub default_slots_per_run { $_[0]->{+DEFAULT_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_RUN, default => $_[0]->max_slots_per_run) } + +sub _get_config_option { + my $self = shift; + my ($field, %opts) = @_; + + my $val = $self->{+HOST_CONF}->{$field} // $self->{+COMMON_CONF}->{$field} // $opts{default}; + + die "'$field' not set in '$self->{+CONFIG_FILE}' for host '$self->{+HOST}' or under 'COMMON' config.\n" + if $opts{required} && !defined($val); + + return $val; +} + +sub algorithm { + my $self = shift; + + return $self->{+ALGORITHM} if $self->{+ALGORITHM}; + + my $algorithm = $self->_get_config_option(+ALGORITHM, default => 'fair'); + + if ($algorithm =~ m/^(.*)::([^:]+)$/) { + my ($mod, $sub) = ($1, $2); + require(mod2file($mod)); + } + else { + require Test2::Harness::Runner::Resource::SharedJobSlots::State; + + my $short = $algorithm; + $algorithm = "_redistribute_$algorithm"; + + die "'$short' is not a valid algorithm (in file '$self->{+CONFIG_FILE}' under host '$self->{+HOST}' key 'algorithm'). Must be 'fair', 'first', or a Fully::Qualified::Module::function_name." + unless Test2::Harness::Runner::Resource::SharedJobSlots::State->can($algorithm); + } + + return $self->{+ALGORITHM} = $algorithm; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::Config - Config for shared job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm b/bad/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm new file mode 100644 index 000000000..86646242f --- /dev/null +++ b/bad/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm @@ -0,0 +1,384 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/time/; +use List::Util qw/min sum0 max/; +use Carp qw/croak/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase qw{ + <max_slots + <max_slots_per_job + <max_slots_per_run + <min_slots_per_run + <default_slots_per_job + <default_slots_per_run + + <my_max_slots + <my_max_slots_per_job + + <algorithm + + <ready_assignments +}; + +use constant RUNNERS => 'runners'; +use constant RUNNER_ID => 'access_id'; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'max_slots' is a required attribute" unless $self->{+MAX_SLOTS}; + croak "'max_slots_per_job' is a required attribute" unless $self->{+MAX_SLOTS_PER_JOB}; + croak "'max_slots_per_run' is a required attribute" unless $self->{+MAX_SLOTS_PER_RUN}; + + $self->{+MY_MAX_SLOTS} //= $self->{+MAX_SLOTS}; + $self->{+MY_MAX_SLOTS_PER_JOB} //= $self->{+MAX_SLOTS_PER_JOB}; + + $self->{+MIN_SLOTS_PER_RUN} //= 0; + + $self->{+ACCESS_META}->{name} //= $self->{+ACCESS_ID}; + + $self->{+ALGORITHM} //= '_redistribute_fair'; +} + +sub init_state { + my $self = shift; + my $state = $self->SUPER::init_state(); + $state->{+RUNNERS} = {}; + return $state; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $removed = $self->SUPER::_clear_old_registrations(@_); + + my $runners = $state->{+RUNNERS}; + delete $runners->{$_} for @$removed; + + return $removed; +} + +sub allocate_slots { + my $self = shift; + my (%params) = @_; + + my $con = $params{con} or croak "'con' is required"; + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_allocate_slots', con => $con, job_id => $job_id); +} + +sub assign_slots { + my $self = shift; + my (%params) = @_; + + my $job = $params{job} or croak "'job' is required"; + + return $self->transaction(rw => '_assign_slots', job => $job); +} + +sub release_slots { + my $self = shift; + my (%params) = @_; + + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_release_slots', job_id => $job_id); +} + +sub _get_runner_entry { + my $self = shift; + my ($state, $runner_id) = @_; + + $runner_id //= $self->{+RUNNER_ID}; + + return $state->{+RUNNERS}->{$runner_id} //= { + runner_id => $runner_id, + added => time, + + todo => 0, + allocated => 0, + allotment => 0, + assigned => {}, + + max_slots => $self->{+MY_MAX_SLOTS}, + max_slots_per_job => $self->{+MY_MAX_SLOTS_PER_JOB}, + }; +} + +sub _allocate_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job_id = $params{job_id}; + my $con = $params{con}; + my ($min, $max) = @$con; + $self->_runner_todo($entry, $job_id => $max); + + my $allocated = $entry->{allocated} //= 0; + + # We have what we need already allocated + return $entry->{allocated} = $max + if $max <= $allocated; + + return $entry->{allocated} + if $entry->{allocated} >= $min; + + # Our allocation, if any, is not big enough, free it so we do not have a + # deadlock with all runner holding an insufficient allocation. + $allocated = $entry->{allocated} = 0; + + my $calcs = $self->_runner_calcs($entry); + + for (0 .. 1) { + $self->_redistribute($state) if $_; # Only run on second loop + + # Cannot do anything if we have no allotment or no available slots. + # This will go to the next loop for a redistribution, or end the loop. + my $allotment = $entry->{allotment} or next; + my $available = $allotment - $calcs->{assigned} or next; + + # If we get here we have an allotment (not 0) but it does not mean the + # minimum, so we have to skip the test. + return -1 if $allotment < $min; + + next unless $available >= $min; + + return $entry->{allocated} = min($available, $max); + } + + return 0; +} + +sub _assign_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job = $params{job}; + my $job_id = $job->{job_id}; + my $allocated = $entry->{allocated}; + + $self->_runner_todo($entry, $job_id => -1); + + $job->{count} = $allocated; + $job->{started} = time; + + $entry->{allocated} = 0; + + $entry->{assigned}->{$job->{job_id}} = $job; + + return $job; +} + +sub _release_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + + my $job_id = $params{job_id}; + + delete $entry->{assigned}->{$job_id}; + delete $entry->{_calc_cache}; + + $self->_runner_todo($entry, $job_id => -1); + + # Reduce our allotment if it makes sense to do so. + my $calcs = $self->_runner_calcs($entry); + $entry->{allotment} = $calcs->{total} if $entry->{allotment} > $calcs->{total}; +} + +sub _runner_todo { + my $sef = shift; + my ($entry, $job_id, $count) = @_; + + my $jobs = $entry->{jobs} //= {}; + + if ($count) { + if ($count < 0) { + $count = delete $jobs->{$job_id}; + } + else { + $jobs->{$job_id} = $count; + } + } + elsif ($job_id) { + $count = $jobs->{$job_id}; + } + + $entry->{todo} = sum0(values %$jobs); + + return $count; +} + +sub _runner_calcs { + my $self = shift; + my ($runner) = @_; + + return $runner->{_calc_cache} if $runner->{_calc_cache}; + + my $max = min(grep {$_} $self->{+MAX_SLOTS_PER_RUN}, $runner->{max_slots}); + my $assigned = sum0(map { $_->{count} } values %{$runner->{assigned} //= {}}); + my $active = $runner->{allocated} + $assigned; + my $total = $runner->{todo} + $active; + my $wants = ($total >= $max) ? max($max, $active) : max($total, $active); + + return $runner->{_calc_cache} = { + max => $max, + assigned => $assigned, + active => $active, + total => $total, + wants => $wants, + }; +} + +sub _redistribute { + my $self = shift; + my ($state) = @_; + + my $max_run = $self->{+MAX_SLOTS_PER_RUN}; + + my $wanted = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + $runner->{allotment} = $calcs->{wants}; + $wanted += $calcs->{wants}; + } + + # Everyone gets what they want! + my $max = $self->{+MAX_SLOTS}; + return if $wanted <= $max; + + my $meth = $self->{+ALGORITHM}; + + return $self->$meth($state); +} + +sub _redistribute_first { + my $self = shift; + my ($state) = @_; + + my $min = $self->{+MIN_SLOTS_PER_RUN}; + my $max = $self->{+MAX_SLOTS}; + + my $c = 0; + for my $runner (sort { $a->{added} <=> $b->{added} } values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + my $wants = $calcs->{wants}; + + if ($max >= $wants) { + $runner->{allotment} = $wants; + } + else { + $runner->{allotment} = max($max, $min, 0); + } + + $max -= $runner->{allotment}; + + $c++; + } + + return; +} + +sub _redistribute_fair { + my $self = shift; + my ($state) = @_; + + my $runs = scalar keys %{$state->{+RUNNERS}}; + + # Avoid a divide by 0 below. + return unless $runs; + + my $total = $self->{+MAX_SLOTS}; + my $min = $self->{+MIN_SLOTS_PER_RUN}; + + my $used = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + + # We never want less than the 'active' number + my $set = $calcs->{active}; + + # If min is greater than the active number and there are todo tests, we + # use the min instead. + $set = $min if $set < $min && $runner->{todo}; + + $runner->{allotment} = $set; + $used += $set; + } + + my $free = $total - $used; + return unless $free >= 1; + + # Is there a more efficient way to do this? Yikes! + my @runners = values %{$state->{+RUNNERS}}; + while ($free > 0) { + @runners = sort { $a->{allotment} <=> $b->{allotment} || $a->{added} <=> $b->{added} } + grep { my $c = $self->_runner_calcs($_); $c->{wants} > $_->{allotment} } + @runners; + + $free--; + $runners[0]->{allotment}++; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::State - shared state for job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Run.pm b/bad/Test2/Harness/Runner/Run.pm new file mode 100644 index 000000000..0bf6d3555 --- /dev/null +++ b/bad/Test2/Harness/Runner/Run.pm @@ -0,0 +1,92 @@ +package Test2::Harness::Runner::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use File::Spec(); + +use Test2::Harness::Util::File::JSONL; + +use parent 'Test2::Harness::Run'; +use Test2::Harness::Util::HashBase qw{ + <workdir + + +run_dir +}; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'workdir' is a required attribute" unless $self->{+WORKDIR}; +} + +sub run_dir { $_[0]->{+RUN_DIR} //= $_[0]->SUPER::run_dir($_[0]->{+WORKDIR}) } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Run - Runner specific subclass of a test run. + +=head1 DESCRIPTION + +Runner subclass of L<Test2::Harness::Run> for use inside the runner. + +=head1 METHODS + +In addition to the methods provided by L<Test2::Harness::Run>, these are provided. + +=over 4 + +=item $dir = $run->workdir + +Runner directory. + +=item $dir = $run->run_dir + +Directory specific to this run. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Scheduler.pm b/bad/Test2/Harness/Runner/Scheduler.pm new file mode 100644 index 000000000..ad77fd230 --- /dev/null +++ b/bad/Test2/Harness/Runner/Scheduler.pm @@ -0,0 +1,57 @@ +package Test2::Harness::Runner::Scheduler; +use strict; +use warnings; + +use Test2::Harness::Runner::Constants qw/CATEGORIES DURATIONS/; +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase(qw{ <preloader <state }); + +sub advance { croak(ref($_[0]) . " does not implement 'advance()'") } +sub all_done { croak(ref($_[0]) . " does not implement 'all_done()'") } +sub halt_run { croak(ref($_[0]) . " does not implement 'halt_run()'") } +sub start_job { croak(ref($_[0]) . " does not implement 'start_job()'") } +sub stop_job { croak(ref($_[0]) . " does not implement 'stop_job()'") } +sub retry_job { croak(ref($_[0]) . " does not implement 'retry_job()'") } +sub queue_job { croak(ref($_[0]) . " does not implement 'queue_job()'") } +sub queue_spawn { croak(ref($_[0]) . " does not implement 'queue_spawn()'") } +sub next_task { croak(ref($_[0]) . " does not implement 'next_task()'") } + +sub job_fields { + my $self = shift; + my ($job) = @_; + + my $run_id = $job->{run_id} or die "No run id provided by job"; + my $cat = $job->{category} or die "No category provided by job"; + my $dur = $job->{duration} or die "No duration provided by job"; + + die "Invalid category: $cat" unless CATEGORIES->{$cat}; + die "Invalid duration: $dur" unless DURATIONS->{$dur}; + + $cat = 'conflicts' if $cat eq 'general' && $job->{conflicts} && @{$job->{conflicts}}; + + my $smoke = $job->{smoke} ? 'smoke' : 'main'; + my $stage = $self->task_stage($job); + + return { + run_id => $run_id, + smoke => $smoke, + stage => $stage, + category => $cat, + duration => $dur, + }; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + my $preloader = $self->preloader or return $wants // 'DEFAULT'; + + return $preloader->task_stage($task->{file}, $wants); +} + +1; diff --git a/bad/Test2/Harness/Runner/Scheduler/Default.pm b/bad/Test2/Harness/Runner/Scheduler/Default.pm new file mode 100644 index 000000000..fd11f26cb --- /dev/null +++ b/bad/Test2/Harness/Runner/Scheduler/Default.pm @@ -0,0 +1,1194 @@ +package Test2::Harness::Runner::Scheduler::Default; +use strict; +use warnings; + +use Carp qw/croak/; + +sub queue_run { + my $self = shift; + my %params = @_; + + my $run_id = $params{run_id} or croak "run_id is required"; + + return $self->_queue_run(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_queue_run(%params, transaction_data => $data); + }); +} + +sub queue_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id} or croak "job_id is required"; + + return $self->_queue_job(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_queue_job(%params, transaction_data => $data); + }); +} + +sub queue_spawn { + my $self = shift; + my %params = @_; + + my $spawn_id = $params{spawn_id} or croak "spawn_id is required"; + + return $self->_queue_spawn(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_queue_spawn(%params, transaction_data => $data); + }); +} + +sub _queue_spawn { + my $self = shift; + my %params = @_; + + my $spawn_id = $params{spawn_id}; + my $data = $params{transaction_data}; + + push @{$data->scheduler_data->{spawn_queue} //= []} => $spawn_id; +} + +sub start_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id} or croak "job_id is required"; + my $pid = $params{pid} or croak "pid is required"; + + return $self->_start_job(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_start_job(%params, transaction_data => $data); + }); +} + +sub stop_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id} or croak "job_id is required"; + + return $self->_stop_job(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_stop_job(%params, transaction_data => $data); + }); +} + +sub retry_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id} or croak "job_id is required"; + + return $self->_retry_job(%params) if $params{transaction_data}; + + $self->state->transaction(w => sub { + my ($self, $data) = @_; + $self->_retry_job(%params, transaction_data => $data); + }); +} + +sub _queue_run { + my $self = shift; + my %params = @_; + + my $data = $params{transaction_data}; + my $run_id = $params{run_id}; + my $run = $params{run} //= $data->uuid_index->{$run_id} // die "Could not find run '$run_id'"; + + push @{$data->scheduler_data->{run_queue} //= []} => $run_id; +} + +sub _queue_job { + my $self = shift; + my %params = @_; + + my $data = $params{transaction_data}; + my $job_id = $params{job_id}; + my $job = $params{job} //= $data->uuid_index->{$job_id} // die "Could not find job '$job_id'"; + + my $list = $self->pending_job_lookup(%params); + push @$list => $job_id; +} + +sub _pending_job_lookup { + my $self = shift; + my %params = @_; + + my $data = $params{transaction_data}; + my $job_id = $params{job_id}; + my $job = $params{job} //= $data->uuid_index->{$job_id} // die "Could not find job '$job_id'"; + + my $fields = $self->job_fields($job); + + return $data->scheduler_data->{'job_queue'}->{$fields->{run_id}}->{$fields->{smoke}}->{$fields->{stage}}->{$fields->{category}}->{$fields->{duration}} //= []; +} + +sub advance { + my $self = shift; + + return 1 if $self->advance_tasks(); + return $self->clear_finished_runs(); +} + +sub advance_tasks { + my $self = shift; + + my $out = 0; + $self->state->transaction(w => sub { + my ($state, $data) = @_; + + my $resources = $state->resources; + + for my $resource (@$resources) { + $resource->refresh(); + + next unless $resource->job_limiter; + return if $resource->job_limiter_at_max(); + } + + my ($run_stage, $task, $res, %params) = $self->_next($data); + + if ($task) { + $out = 1; + push @{$data->scheduler_data->{'ready'}->{$run_stage} //= []} => {job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}; + } + + $_->discharge() for @$resources; + }); + + return $out; +} + +my %SORTED; +sub _next { + my $self = shift; + my ($data) = @_; + + my $pending = $data->scheduler_data->{'job_queue'} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->state->resources; + + # Ugly.... + my $search = $pending; + + for my $run_id (@{$data->scheduler_data->{run_queue} //= []}) { + my $search = $search->{$run_id} or next; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + } + + return; +} + + +sub next_task { + my $self = shift; +} + +sub _start_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id}; + my $data = $params{transaction_data}; + + push @{$data->scheduler_data->{spawn_queue} //= []} => $spawn_id; + warn "FIXME"; +} + + +sub _stop_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id}; + my $data = $params{transaction_data}; + + warn "FIXME"; +} + +sub _retry_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id}; + my $data = $params{transaction_data}; + + warn "FIXME"; +} + +sub all_done { } +sub halt_run { } + +1; + +__END__ + +sub task_pending_lookup { + my $self = shift; + my ($task) = @_; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + + + + $self->transaction(w => sub { + my ($self, $data) = @_; + + for my $id (keys %{$data->uuid_index}) { + my $remove = 0; + $remove ||= $id eq $run_id; + $remove ||= $data->{run_id} eq $run_id; + next unless $remove; + + my $data = $data->uuid_index->{$id}; + if (my $pid = $data->{pid}) { + if ($pid != $$) { + print STDERR "Killing $pid: " . ($data->{description} // 'UNKNOWN') . "...\n"; + kill('INT', $pid); + } + } + } + }); + + for my $task (values %$running) { + next unless $task->{run_id} && $task->{run_id} eq $self->{+RUN_ID}; + my $pids = $self->get_job_pids($task->{job_id}) // next; + + my $file = $task->{rel_file}; + print "Killing test $file...\n"; + kill('INT', @$pids); + } + +1; + +__END__ + + +package Test2::Harness::Runner::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::State; + +use Test2::Harness::Settings; +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run; +use Test2::Harness::Util::Queue; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase( + # These are construction arguments + qw{ + <eager_stages + <state + <workdir + <preloader + <no_poll + <resources + job_count + +settings + }, + + qw{ + <dispatch_file + <queue_ended + + <pending_tasks <task_lookup + <pending_runs +run <stopped_runs + <pending_spawns + + <running + <running_categories + <running_durations + <running_conflicts + <running_tasks + + <stage_readiness + + <task_list + + <halted_runs + + <reload_state + + <observe + }, +); + +sub init { + my $self = shift; + + croak "You must specify a workdir or provide state" + unless $self->{+STATE} || defined $self->{+WORKDIR}; + + $self->{+WORKDIR} //= $self->{+STATE}->workdir; + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; + + if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { + my $settings = $self->settings; + my $resources = $self->{+RESOURCES} //= []; + for my $res (@{$self->settings->runner->resources}) { + require(mod2file($res)); + push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); + } + } + + unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { + require Test2::Harness::Runner::Resource::JobCount; + push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); + } + + @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; + + $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); + + $self->{+RELOAD_STATE} //= {}; + + $self->poll; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->state->settings; +} + +sub run { + my $self = shift; + return $self->{+RUN} if $self->{+RUN}; + $self->poll(); + return $self->{+RUN}; +} + +sub done { + my $self = shift; + + $self->poll(); + + return 0 if $self->{+RUNNING}; + return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; + + return 0 if $self->{+RUN}; + return 0 if @{$self->{+PENDING_RUNS} //= []}; + + return 0 unless $self->{+QUEUE_ENDED}; + + return 1; +} + +sub next_task { + my $self = shift; + my ($stage) = @_; + + $self->poll(); + $self->clear_finished_run(); + + while(1) { + if (@{$self->{+PENDING_SPAWNS} //= []}) { + my $spawn = shift @{$self->{+PENDING_SPAWNS}}; + next unless $spawn->{stage} eq $stage; + $self->start_spawn($spawn); + return $spawn; + } + + my $task = shift @{$self->{+TASK_LIST}} or return undef; + + # If we are replaying a state then the task may have already completed, + # so skip it if it is not in the running lookup. + next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; + next unless $task->{stage} eq $stage; + + return $task; + } +} + +sub advance { + my $self = shift; + $self->poll(); + + $_->tick() for @{$self->{+RESOURCES} //= []}; + + $self->advance_run(); + return 0 unless $self->{+RUN}; + return 1 if $self->advance_tasks(); + return $self->clear_finished_run(); +} + +my %ACTIONS = ( + queue_run => '_queue_run', + queue_task => '_queue_task', + queue_spawn => '_queue_spawn', + start_spawn => '_start_spawn', + start_run => '_start_run', + start_task => '_start_task', + stop_run => '_stop_run', + stop_task => '_stop_task', + retry_task => '_retry_task', + stage_ready => '_stage_ready', + stage_down => '_stage_down', + end_queue => '_end_queue', + halt_run => '_halt_run', + truncate => '_truncate', + reload => '_reload', +); + +sub poll { + my $self = shift; + + return if $self->{+NO_POLL}; + + my $queue = $self->dispatch_file; + + for my $item ($queue->poll) { + my $data = $item->[-1]; + my $item = $data->{item}; + my $action = $data->{action}; + my $pid = $data->{pid}; + + my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; + + $self->$sub($item, $pid); + } +} + +sub _enqueue { + my $self = shift; + my ($action, $item) = @_; + $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); + $self->poll; +} + +sub truncate { + my $self = shift; + $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; + $self->_enqueue(truncate => $$); + $self->poll; +} + +sub _truncate { } + +sub end_queue { $_[0]->_enqueue('end_queue' => 1) } +sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } + +sub halt_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(halt_run => $run_id); + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run_id}; + $data->jobs->{$run_id}->{closed} = 1; + }); +} + +sub _halt_run { + my $self = shift; + my ($run_id) = @_; + + delete $self->{+PENDING_TASKS}->{$run_id}; + + $self->{+HALTED_RUNS}->{$run_id}++; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + $self->_enqueue(queue_run => $run); +} + +sub _queue_run { + my $self = shift; + my ($run) = @_; + + push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( + %$run, + workdir => $self->{+WORKDIR}, + state => $self->{+STATE}, + ); + + return; +} + +sub start_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(start_run => $run_id); +} + +sub _start_run { + my $self = shift; + my ($run_id) = @_; + + my $run = shift @{$self->{+PENDING_RUNS}}; + die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; + die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; + + $self->{+RUN} = $run; + + return; +} + +sub stop_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(stop_run => $run_id); +} + +sub _stop_run { + my $self = shift; + my ($run_id) = @_; + + $self->{+STOPPED_RUNS}->{$run_id} = 1; + + return; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + $spawn->{spawn} //= 1; + $spawn->{id} //= gen_uuid(); + $self->_enqueue(queue_spawn => $spawn); +} + +sub _queue_spawn { + my $self = shift; + my ($spawn) = @_; + + $spawn->{id} //= gen_uuid(); + $spawn->{spawn} //= 1; + $spawn->{use_preload} //= 1; + + $spawn->{stage} //= 'default'; + $spawn->{stage} = $self->task_stage($spawn); + + push @{$self->{+PENDING_SPAWNS}} => $spawn; + + return; +} + +sub start_spawn { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_spawn => $spec); +} + +sub _start_spawn { + my $self = shift; + my ($spec) = @_; + + my $uuid = $spec->{id} or die "Could not find UUID for spawn"; + + @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; + + return; +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + $self->_enqueue(queue_task => $task); +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + my $job_id = $task->{job_id} or die "Task missing job_id"; + my $run_id = $task->{run_id} or die "Task missing run_id"; + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + +sub start_task { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_task => $spec); +} + +sub _start_task { + my $self = shift; + my ($spec) = @_; + + my $job_id = $spec->{job_id} or die "No job_id provided"; + my $run_stage = $spec->{stage} or die "No stage provided"; + my $res = $spec->{res} or die "No res provided"; + my $res_skip = $spec->{resource_skip}; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; + my $count = @$set; + @$set = grep { $_->{job_id} ne $job_id } @$set; + die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; + + $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); + + # Set the stage, new task hashref + $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; + + $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + push @{$task->{test_args}} => @{$res->{args}}; + + for my $resource (@{$self->{+RESOURCES}}) { + my $class = ref($resource); + my $val = $res->{record}->{$class} // next; + $resource->record($task->{job_id}, $val); + } + + die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; + $self->{+RUNNING_TASKS}->{$job_id} = $task; + + $task->{resource_skip} = $res_skip if $res_skip; + + push @{$self->{+TASK_LIST}} => $task; + + $self->{+RUNNING}++; + $self->{+RUNNING_CATEGORIES}->{$cat}++; + $self->{+RUNNING_DURATIONS}->{$dur}++; + + my $cfls = $task->{conflicts} //= []; + for my $cfl (@$cfls) { + die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" + if $self->{+RUNNING_CONFLICTS}->{$cfl}++; + } + + return; +} + +sub stop_task { + my $self = shift; + my ($job_id) = @_; + $self->_enqueue(stop_task => $job_id); +} + +sub _stop_task { + my $self = shift; + my ($job_id) = @_; + + my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; + + delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; + + $_->release($job_id) for @{$self->{+RESOURCES}}; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + $self->{+RUNNING}--; + $self->{+RUNNING_CATEGORIES}->{$cat}--; + $self->{+RUNNING_DURATIONS}->{$dur}--; + + my $cfls = $task->{conflicts} //= []; + $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; + + return; +} + +sub retry_task { + my $self = shift; + my ($job_id) = @_; + + $self->_enqueue(retry_task => $job_id); +} + +sub _retry_task { + my $self = shift; + my ($job_id) = @_; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; + + $self->_stop_task($job_id); + + return if $self->{+HALTED_RUNS}->{$task->{run_id}}; + + $task = {is_try => 0, %$task}; + $task->{is_try}++; + $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; + + $self->_queue_task($task); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_ready => $stage); +} + +sub _stage_ready { + my $self = shift; + my ($stage, $pid) = @_; + + $self->{+STAGE_READINESS}->{$stage} = $pid // 1; + + return; +} + +sub stage_down { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_down => $stage); +} + +sub _stage_down { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE_READINESS}->{$stage} = 0; + + return; +} + +sub reload { + my $self = shift; + my ($stage, $data) = @_; + $stage //= 'default'; + $self->_enqueue(reload => {%$data, stage => $stage}); + return; +} + +sub _reload { + my $self = shift; + my ($data) = @_; + + my $stage = $data->{stage}; + my $file = $data->{file}; + my $success = $data->{reloaded}; + my $error = $data->{error}; + my $warnings = $data->{warnings}; + + my $reload_state = $self->{+RELOAD_STATE} //= {}; + my $stage_state = $reload_state->{$stage} //= {}; + + # It either succeeded, or the stage will be reloaded, no need to track brokenness + if (defined $success) { + delete $stage_state->{$file}; + } + else { + my $fields = {}; + $fields->{error} = $error if defined($error) && length($error); + $fields->{warnings} = $warnings if $warnings && @{$warnings}; + + if (keys %$fields) { + $stage_state->{$file} = $fields; + } + else { + delete $stage_state->{$file}; + } + } + + return; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + return $wants if $self->{+NO_POLL}; + + return $wants // 'DEFAULT' unless $self->preloader; + return $self->preloader->task_stage($task->{file}, $wants); +} + +sub prune_hash { + my $self = shift; + my ($hash, @path) = @_; + + die "No path!" unless @path; + + my $key = shift @path; + + if (@path) { + my $empty = $self->prune_hash($hash->{$key}, @path); + return 0 unless $empty; + } + + return 1 unless exists $hash->{$key}; + + my $ref = ref($hash->{$key}); + if ($ref eq 'HASH') { + return 0 if keys %{$hash->{$key}}; + } + elsif ($ref eq 'ARRAY') { + return 0 if @{$hash->{$key}}; + } + + delete $hash->{$key}; + return 1; +} + +sub advance_run { + my $self = shift; + + return 0 if $self->{+RUN}; + + return 0 unless @{$self->{+PENDING_RUNS} //= []}; + $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); + + return 1; +} + +sub clear_finished_run { + my $self = shift; + + my $run = $self->{+RUN} or return 0; + + return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; + return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; + return 0 if $self->{+RUNNING}; + + delete $self->{+RUN}; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run->run_id}; + $data->jobs->{$run->run_id}->{closed} = 1; + }); + + return 1; +} + +sub _cat_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; + + # Only search isolation if nothing is running. + push @cat_order => 'isolation' unless $self->{+RUNNING}; + + return \@cat_order; +} + +sub _dur_order { + my $self = shift; + + my $max = 0; + for my $resource (@{$self->resources}) { + next unless $resource->job_limiter; + my $val = $resource->job_limiter_max; + $max = $val if !$max || $val < $max; + } + $max //= 1; + + my $maxm1 = $max - 1; + + my $durs = $self->{+RUNNING_DURATIONS}; + + # 'short' is always ok. + my @dur_order = ('short'); + + # long and medium should be on the front of the search unless we are + # already running (max - 1) tests of the duration We want long first if + # we are not saturation on them, followed by medium, whcih is why they + # are listed in this order. + for my $c (qw/medium long/) { + if ($durs->{$c} && $durs->{$c} >= $maxm1) { + push @dur_order => $c; # Back of the list + } + else { + unshift @dur_order => $c; # Front of the list + } + } + + return \@dur_order; +} + +# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in +# which we search for tasks, 'RUN_STAGE' is the stage that actually does the +# work. This is what allows us to find tasks for 'eager' stages that are bored. +sub _stage_order { + my $self = shift; + + my $stage_check = $self->{+STAGE_READINESS} //= {}; + + my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; + + # Populate list with all ready stages + my %seen; + my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; + + # Add in any eager stages, but make sure they are last. + for my $rstage (@stage_list) { + next unless exists $self->{+EAGER_STAGES}->{$rstage}; + push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; + } + + return \@stages; +} + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::State - State tracking for the runner. + +=head1 DESCRIPTION + +This module tracks the state for all running tests. This entire module is +considered an "Implementation Detail". Please do not rely on it always staying +the same, or even existing in the future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Runner/Spawn.pm b/bad/Test2/Harness/Runner/Spawn.pm new file mode 100644 index 000000000..5bb3b83f3 --- /dev/null +++ b/bad/Test2/Harness/Runner/Spawn.pm @@ -0,0 +1,89 @@ +package Test2::Harness::Runner::Spawn; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Job'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + + $self->{+RUN} //= Test2::Harness::Runner::Spawn::Run->new(); +} + +sub out_file { sprintf('/proc/%i/fd/1', $_[0]->{+TASK}->{owner}) } +sub err_file { sprintf('/proc/%i/fd/2', $_[0]->{+TASK}->{owner}) } +sub in_file { undef } + +sub args { @{$_[0]->{+TASK}->{args} //= []} } + +sub job_dir { "" } +sub run_dir { "" } + +sub use_stream { 0 } +sub event_uuids { 0 } +sub mem_usage { 0 } +sub io_events { 0 } + +# These return lists +sub load_import { } +sub load { } + +package Test2::Harness::Runner::Spawn::Run; + +sub new { bless {}, shift }; + +sub env_vars { {} } + +sub AUTOLOAD { } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Spawn - Minimal job class used for spawning processes + +=head1 DESCRIPTION + +Do not use this directly... + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib/Test2/Harness/Settings.pm b/bad/Test2/Harness/Settings.pm similarity index 100% rename from lib/Test2/Harness/Settings.pm rename to bad/Test2/Harness/Settings.pm diff --git a/lib/Test2/Harness/Settings/Prefix.pm b/bad/Test2/Harness/Settings/Prefix.pm similarity index 100% rename from lib/Test2/Harness/Settings/Prefix.pm rename to bad/Test2/Harness/Settings/Prefix.pm diff --git a/bad/Test2/Harness/State.pm b/bad/Test2/Harness/State.pm new file mode 100644 index 000000000..2013029aa --- /dev/null +++ b/bad/Test2/Harness/State.pm @@ -0,0 +1,765 @@ +package Test2::Harness::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; + +use Test2::Harness::State::Instance; +use Test2::Harness::Settings; + +use Carp qw/croak confess carp/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util qw/mod2file clean_path/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <workdir + + +resources +resource_list +resource_lookup + +plugins +plugin_list +plugin_lookup + +renderer +renderer_list +renderer_lookup + +job_count + +settings + + +scheduler_class +ipc_model_class + + <observe + }, +); + +sub state_class { 'Test2::Harness::State::Instance' } + +sub access_id { $_[0]->_access->[0] } +sub access_pid { $_[0]->_access->[1] } +sub registered { $_[0]->_access->[2] } + +{ + no warnings 'once'; + sub running_tasks { croak "Should just grab the jobs structure" } + sub run { croak "Removing the concept of a 'single' active run" } + *pending_runs = \&run; +} + +sub change_access { + my $self = shift; + my ($access_id) = @_; + + $self->{+ACCESS_PID} = $$; + $self->{+ACCESS_ID} = $access_id // $$; + delete $self->{+REGISTERED}; + + return $self->{+ACCESS_ID}; +} + +sub _access { + my $self = shift; + + my $id = $self->{+ACCESS_ID}; + my $pid = $self->{+ACCESS_PID}; + + if (defined $pid) { + return [$id // $pid, $pid, $self->{+REGISTERED} ? 1 : 0] if $pid && $pid == $$; + } + + if(defined($id) || defined($pid)) { + delete $self->{+ACCESS_ID}; + delete $self->{+ACCESS_PID}; + } + + if (my $rpid = $self->{+REGISTERED}) { + delete $self->{+REGISTERED} unless $rpid == $$; + } + + return [$$, $$, $self->{+REGISTERED} ? 1 : 0]; +} + +sub init { + my $self = shift; + + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + $self->SUPER::init(); + + my @bad = grep { !$self->can(uc($_)) } keys %$self; + croak "The following invalid keys were passed into the constructor: " . join(', ' => @bad) + if @bad; + + $self->{+PLUGIN_LOOKUP} //= {}; +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->SUPER::sync_from_state($state); + + $self->{+WORKDIR} = $state->{workdir}; +} + +sub init_state { + my $self = shift; + + confess "Attempt to initialize state from an observer" + if $self->{+OBSERVE}; + + my $state = $self->SUPER::init_state(); + + $state = $self->state_class->init_state($self, $state); + + return $state; +} + +sub ipc_model_class { + my $self = shift; + return $self->{+IPC_MODEL_CLASS} //= $self->transaction(r => sub { + my ($self, $data) = @_; + my $class = $data->ipc_model_class; + require(mod2file($class)); + return $class; + }); +} + +sub scheduler { + my $self = shift; + return $self->scheduler_class->new(state => $self, @_); +} + +sub scheduler_class { + my $self = shift; + return $self->{+SCHEDULER_CLASS} //= $self->transaction(r => sub { + my ($self, $data) = @_; + my $class = $data->scheduler_class; + require(mod2file($class)); + return $class; + }); +} + +sub ipc_model { + my $self = shift; + return $self->ipc_model_class->new(state => $self); +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[1]->settings}) }); +} + +sub job_count { + my $self = shift; + return $self->{+JOB_COUNT} //= $self->transaction(r => sub { $_[1]->job_count }); +} + +sub _init_resources { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + my $has_limiter = undef; + + for my $res (@$list) { + my ($type, $inst); + if ($type = ref($res)) { + $inst = $res; + } + else { + $type = $res; + require(mod2file($res)); + $inst = $res->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + push @inst => $inst; + push @store => $type; + + $has_limiter ||= $inst->job_limiter; + } + + unless ($has_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + push @store => 'Test2::Harness::Runner::Resource::JobCount'; + push @inst => Test2::Harness::Runner::Resource::JobCount->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + return (\@store, \@inst); +} + +sub resource_list { + my $self = shift; + return $self->{+RESOURCE_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $list; + }); +} + +sub resources { + my $self = shift; + my ($name, $cb) = @_; + + my $resources = $self->{+RESOURCES} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $inst; + }); + + return $resources unless $name && $cb; + + return $self->{+RESOURCE_LOOKUP}->{$name} //= [grep { $cb->($_) } @$resources]; +} + +sub _init_plugins { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + for my $p (@$list) { + my ($type, $inst); + if ($type = ref($p)) { + $inst = $p; + } + else { + $type = $p; + require(mod2file($p)); + $inst = $p->new(settings => $settings) if $p->can('new'); + } + + push @store => $type; + push @inst => $inst; + } + + return (\@store, \@inst); +} + +sub plugin_list { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGIN_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $list; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "MODS-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +sub plugins { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGINS} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $inst; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "INST-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +sub add_yath_process { + my $self = shift; + my ($name, $pid, $parent) = @_; + + croak "'name' is a required argument" unless $name; + croak "'pid' is a required argument" unless $pid; + + my $proc_id = gen_uuid(); + + $self->transaction(w => sub { + my ($self, $data) = @_; + + my $procs = $data->yath_processes; + croak "Process with name '$name' has already been added" if $procs->{$name}; + + $procs->{$name} = $proc_id; + $data->uuid_index->{$proc_id} = {proc => $name, proc_id => $proc_id, pid => $pid, parent => $parent}; + $data->pid_index->{$pid} = $proc_id; + }); +} + +sub remove_yath_process { + my $self = shift; + my ($name) = @_; + + croak "'name' is a required argument" unless $name; + + my $proc_id; + + $self->transaction(w => sub { + my ($self, $data) = @_; + + my $procs = $data->yath_processes; + $proc_id = delete $procs->{$name} or croak "No such process '$name'"; + + my $proc_data = delete $data->uuid_index->{$proc_id}; + delete $data->pid_index->{$proc_data->{pid}} if $proc_data->{pid}; + }); + + return $proc_id; +} + +sub touch_stages { + my $self = shift; + my (@stages) = @_; + + $self->transaction(w => sub { + my ($self, $data) = @_; + $data->stages->{$_} //= gen_uuid() for @stages; + }); +} + +sub stage_down { + my $self = shift; + my ($stage, %args) = @_; + + croak "'stage' is a required argument" unless $stage; + + $self->transaction(w => sub { + my ($self, $data) = @_; + my $stage_id = $data->stages->{$stage} or die "No stage id for '$stage'"; + my $stage_data = $data->uuid_index->{$stage_id} //= {stage => $stage, stage_id => $stage_id, status => 0}; + + $stage_data->{$_} = $args{$_} for keys %args; + + if (exists $args{pid}) { + delete $stage_data->{parent}; + + if ($args{pid}) { $stage_data->{pid} = $args{pid} } + else { delete $stage_data->{pid} } + } + + if (exists $args{parent}) { + if ($args{parent}) { $stage_data->{parent} = $args{parent} } + else { delete $stage_data->{parent} } + } + + $stage_data->{status} = 0; + delete $stage_data->{reload}; + }); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage, $pid, $parent) = @_; + + croak "'stage' is a required argument" unless $stage; + croak "'pid' is a required argument" unless $pid; + carp "'parent' is a recommended argument" unless $parent; + + $self->transaction(w => sub { + my ($self, $data) = @_; + my $stage_id = $data->stages->{$stage} or die "No stage id for '$stage'"; + my $stage_data = $data->uuid_index->{$stage_id} //= {stage => $stage, stage_id => $stage_id, status => 1}; + + $data->pid_index->{$pid} = $stage_id; + + $stage_data->{pid} = $pid; + $stage_data->{parent} = $parent if $parent; + $stage_data->{status} = 1; + delete $stage_data->{reload}; + }); + + return; +} + +sub stage_update_reload_result { + my $self = shift; + my ($stage, %files) = @_; + + $self->transaction(w => sub { + my ($self, $data) = @_; + my $stage_id = $data->stages->{$stage} or croak "Could not find stage '$stage'"; + my $stage_data = $data->uuid_index->{$stage_id} or croak "Stage '$stage' has no data"; + + my $reload = $stage_data->{reload} //= {}; + $reload->{$_} = $files{$_} or delete $reload->{$_} for keys %files; + }); +} + +sub stage_get_reload_results { + my $self = shift; + my ($stage) = @_; + + return $self->stage_data($stage)->{reload} // {}; +} + +sub stage_data { + my $self = shift; + + return $self->data->stages unless @_; + my ($stage) = @_; + + unless ($stage) { + my $display = defined($stage) ? "'$stage'" : '|undef|'; + carp "Stage $display does not seem like a valid stage"; + } + + return $self->data->stages->{$stage}; +} + +sub add_description_prefix { + my $self = shift; + my ($text) = @_; + + my $prefix = $self->settings->debug->procname_prefix or return $text; + return "${prefix}: ${text}"; +} + +sub add_run { + my $self = shift; + my ($run_data, %params) = @_; + + my $run_id = $run_data->{run_id} or croak "No run_id in run data!"; + + $self->transaction(w => sub { + my ($self, $data) = @_; + + croak "Attempted to add run with run id '$run_id', but that run is already in the index" + if $data->uuid_index->{$run_id}; + + my $run = $data->uuid_index->{$run_id} = {run => $run_data, run_id => $run_id}; + + if (my $pid = $params{pid}) { + $run_data->{pid} = $pid; + $data->pid_index->{$pid} = $run_id + } + + $run_data->{parent} = $params{parent} if $params{parent}; + + push @{$data->runs} => $run_id; + $self->scheduler->queue_run(transaction_data => $data, run_id => $run_id, run => $run); + + if (my $jobs = $params{jobs}) { + $self->_add_job($data, $_) for @$jobs; + } + + $run->{description} = $self->add_description_prefix($params{description} // $run_id); + }); + + return $run_id; +} + +sub remove_run { + my $self = shift; + my ($run_id) = @_; + + my $bad = 0; + $self->transaction(w => sub { + my ($self, $data) = @_; + + @{$data->runs} = grep { $_ ne $run_id } @{$data->runs}; + + for my $id (keys %{$data->uuid_index}) { + my $remove = 0; + $remove ||= $id eq $run_id; + $remove ||= $data->{run_id} eq $run_id; + next unless $remove; + + my $data = $data->uuid_index->{$id}; + if (my $pid = $data->{pid}) { + $bad++; + $data->{zombie} = 1; + } + else { + delete $data->uuid_index->{$id}; + } + } + }); + + carp "Removed run '$run_id' still had $bad associated PIDs" + if $bad; + + return; +} + +sub add_job { + my $self = shift; + my ($job) = @_; + + $self->transaction(w => sub { + my ($self, $data) = @_; + $self->_add_job($data, $job); + }); + + return; +} + +sub _add_job { + my $self = shift; + my ($data, $job, %params) = @_; + + $job = {stage => 'DEFAULT', %$job, try => 0}; + my $stage = $job->{stage} or croak "No stage in job data!"; + my $run_id = $job->{run_id} or croak "No run_id in job data!"; + my $job_id = $job->{job_id} or croak "No job_id in job data!"; + + croak "Attempted to add a job for run '$run_id' which is not in the index" + unless $data->uuid_index->{$run_id}; + + croak "Attempted to add job with job id '$job_id', but that job is already in the index" + if $data->uuid_index->{$job_id}; + + my $description = $self->add_description_prefix($params{description} // $job->{rel_file} // $job->{file} // 'a test'); + + $data->uuid_index->{$job_id} = {job => $job, run_id => $run_id, description => $description}; + push @{$data->uuid_index->{$run_id}->{jobs}} => $job_id; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + + my $stage = $spawn->{stage} or croak "No stage in spawn data!"; + + my $id = $spawn->{id} // $gen_uuid(); + my $entry = {spawn => {use_preload => 1, %$spawn, stage => $stage, spawn_id => $id}, spawn_id => $id}; + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + $data->uuid_index->{$id} = $entry; + push @{$data->spawn_queue} => $id; + + $self->scheduler->queue_spawn(transaction_data => $data, spawn => $entry->{spawn}, spawn_id => $id); + }); + + return $id; +} + +sub queue_job { + my $self = shift; + my ($job_id) = @_; + + $self->transaction(w => '_queue_job', job_id => $job_id, scheduler_cb => 'queue_job'); + + return $job_id; +} + +sub retry_job { + my $self = shift; + my ($job_id) = @_; + + $self->transaction(w => '_retry_job', job_id => $job_id, scheduler_cb => 'retry_job'); + + return $job_id; +} + +sub stop_job { + my $self = shift; + my ($job_id) = @_; + + $self->transaction(w => '_stop_job', job_id => $job_id, scheduler_cb => 'stop_job'); + + return $job_id; +} + +sub _queue_job { + my $self = shift; + my ($data, %params) = @_; + + my $job_id = $params{job_id}; + my $scheduler_cb = delete $params{scheduler_cb}; + + my $job = $data->uuid_index->{$job_id} or croak "Could not find job ($job_id)"; + $job = $job->{job} or croak "job id ($job_id) does not exist"; + + $job->{try} //= 0; + + warn "Change this to send an event to the renderer. No need to keep this here"; + push @{$data->job_queue} => $job_id; + + $self->scheduler->$scheduler_cb(%params, transaction_data => $data, job => $job) + if $scheduler_cb; +} + +sub _stop_job { + my $self = shift; + my ($data, %params) = @_; + + my $job_id = $params{job_id}; + my $scheduler_cb = delete $params{scheduler_cb}; + + my $job = $data->uuid_index->{$job_id} or croak "Could not find job ($job_id)"; + delete $job->{parent}; + my $pid = delete $job->{pid}; + delete $data->pid_index->{$pid}; + + warn "Change this to send an event to the renderer. No need to keep this here"; + push @{$data->stopped_jobs} => {%params, try => $job->{try}, job => $job}; + + $self->scheduler->$scheduler_cb(%params, transaction_data => $data) + if $scheduler_cb; +} + +sub _retry_job { + my $self = shift; + my ($data, %params) = @_; + + my $job_id = $params{job_id}; + my $scheduler_cb = delete $params{scheduler_cb}; + + $self->_stop_job($data, %params); + + my $job = $data->uuid_index->{$job_id} or croak "Could not find job ($job_id)"; + my $try = ++$job->{try}; + + $self->_queue_job($data, %params); + + $self->scheduler->$scheduler_cb(%params, transaction_data => $data) + if $scheduler_cb; + + return $try; +} + +sub start_job { + my $self = shift; + my %params = @_; + + my $job_id = $params{job_id} or croak "job_id is required"; + my $pid = $params{pid} or croak "pid is required"; + my $parent = $params{parent}; + + $self->transaction(w => sub { + my ($self, $data) = @_; + + my $job = $data->uuid_index->{$job_id} or croak "Could not find job ($job_id)"; + + croak "Job '$job_id' already has a PID" if $job->{pid}; + + $job->{pid} = $pid; + $job->{parent} = $parent or delete $job->{parent}; + $data->pid_index->{$pid} = $job_id; + + push @{$data->started_jobs} => {%params, try => $job->{try}, job => $job}; + + $self->scheduler->start_job(%params, transaction_data => $data, try => $job->{try}, job => $job); + }); + + return; +} + +1; + +__END__ + +#sub remove_job { +# my $self = shift; +# my ($job_id) = @_; +# +# my @pids; +# +# $self->transaction(w => sub { +# my ($self, $data) = @_; +# my $job_data = $data->uuid_index->{$job_id}; +# +# if (my $pid = $job_data->{pid}) { +# carp "Removed job '$job_id' still had an associated PID"; +# $job_data->{zombie} = 1; +# } +# else { +# delete $data->uuid_index->{$job_id}; +# } +# }); +# +# return \@pids; +#} + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State - State tracking for a yath instance + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/State/Instance.pm b/bad/Test2/Harness/State/Instance.pm new file mode 100644 index 000000000..1e7973231 --- /dev/null +++ b/bad/Test2/Harness/State/Instance.pm @@ -0,0 +1,133 @@ +package Test2::Harness::State::Instance; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <resources + <job_count + <settings + <workdir + <plugins + + <stages + <yath_processes + + <ipc_model_class <ipc_model_data + <scheduler_class <scheduler_data + + <pid_index + <uuid_index + + <spawn_queue + <job_queue + + <runs + }, + + # remove these with new IPC model + qw/ started_jobs stopped_jobs /, +); + +sub init_state { + my $class = shift; + my ($state, $data) = @_; + + $data->{+WORKDIR} //= $state->{workdir} // confess "No workdir"; + $data->{+SETTINGS} //= $state->{settings} // confess "No settings"; + my $settings = $data->{settings}; + + $data->{+RUNS} //= []; + $data->{+SPAWN_QUEUE} //= []; + + $data->{+STAGES} //= {}; + $data->{+JOB_QUEUE} //= {}; + $data->{+PID_INDEX} //= {}; + $data->{+UUID_INDEX} //= {}; + $data->{+YATH_PROCESSES} //= {}; + + $data->{+JOB_COUNT} //= $state->{job_count} // $settings->check_prefix('runner') ? $settings->runner->job_count // 1 : 1; + + $data->{+SCHEDULER_CLASS} //= 'Test2::Harness::Runner::Scheduler::Default'; + $data->{+SCHEDULER_DATA} //= {}; + + $data->{+IPC_MODEL_CLASS} //= 'FIXME'; + $data->{+IPC_MODEL_DATA} //= {}; + + $data->{+STARTED_JOBS} //= []; + $data->{+STOPPED_JOBS} //= []; + + for my $type (qw/resource plugin renderer/) { + my $plural = "${type}s"; + my $raw; + + if ($type eq 'resource') { + next unless $settings->check_prefix('runner'); + $raw = $settings->runner->$plural // []; + @$raw = sort { $a->sort_weight <=> $b->sort_weight } @$raw; + } + else { + next unless $settings->check_prefix('harness'); + next unless $settings->harness->check_field($plural); + $raw = $settings->harness->$plural // []; + } + + $data->{$plural} = [map { ref($_) || $_ } @$raw]; + } + + return bless($data, $class); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State::Instance - Data structure for yath shared state + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/TestFile.pm b/bad/Test2/Harness/TestFile.pm new file mode 100644 index 000000000..6381b1b79 --- /dev/null +++ b/bad/Test2/Harness/TestFile.pm @@ -0,0 +1,695 @@ +package Test2::Harness::TestFile; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Time::HiRes qw/time/; + +use List::Util 1.45 qw/uniq/; + +use Test2::Harness::Util qw/open_file clean_path/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <file +relative <_scanned <_headers +_shbang <is_binary <non_perl + input env_vars test_args + queue_args + job_class + comment + _category _stage _duration _min_slots _max_slots +}; + +sub set_duration { $_[0]->set__duration(lc($_[1])) } +sub set_category { $_[0]->set__category(lc($_[1])) } + +sub set_stage { $_[0]->set__stage($_[1]) } +sub set_min_slots { $_[0]->set__min_slots($_[1]) } +sub set_max_slots { $_[0]->set__max_slots($_[1]) } + +sub retry { $_[0]->headers->{retry} } +sub set_retry { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry} = $val; +} + +sub retry_isolated { $_[0]->headers->{retry_isolated} } +sub set_retry_isolated { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry_isolated} = $val; +} + +sub set_smoke { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{features}->{smoke} = $val; +} + +sub init { + my $self = shift; + + my $file = $self->file; + + # We want absolute path + $file = clean_path($file, 0); + $self->{+FILE} = $file; + + $self->{+QUEUE_ARGS} ||= []; + + croak "Invalid test file '$file'" unless -f $file; + + if($self->{+IS_BINARY} = -B $file && !-z $file) { + $self->{+NON_PERL} = 1; + die "Cannot run binary test file '$file': file is not executable.\n" + unless $self->is_executable; + } +} + +sub relative { + my $self = shift; + return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE}); +} + +my %DEFAULTS = ( + timeout => 1, + fork => 1, + preload => 1, + stream => 1, + run => 1, + isolation => 0, + smoke => 0, + io_events => 1, +); + +sub check_feature { + my $self = shift; + my ($feature, $default) = @_; + + $default = $DEFAULTS{$feature} unless defined $default; + + return $default unless defined $self->headers->{features}->{$feature}; + return 1 if $self->headers->{features}->{$feature}; + return 0; +} + +sub check_stage { + my $self = shift; + + return $self->{+_STAGE} if $self->{+_STAGE}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{stage} || undef; +} + +sub check_min_slots { + my $self = shift; + + return $self->{+_MIN_SLOTS} if $self->{+_MIN_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{min_slots} // undef; +} + +sub check_max_slots { + my $self = shift; + + return $self->{+_MAX_SLOTS} if $self->{+_MAX_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{max_slots} // undef; +} + +sub meta { + my $self = shift; + my ($key) = @_; + + $self->_scan unless $self->{+_SCANNED}; + my $meta = $self->{+_HEADERS}->{meta} or return (); + + return () unless $key && $meta->{$key}; + + return @{$meta->{$key}}; +} + +sub check_duration { + my $self = shift; + + return $self->{+_DURATION} if $self->{+_DURATION}; + + $self->_scan unless $self->{+_SCANNED}; + my $duration = $self->{+_HEADERS}->{duration}; + return $duration if $duration; + + my $timeout = $self->check_feature(timeout => 1); + + # 'long' for anything with no timeout + return 'long' unless $timeout; + + return 'medium'; +} + +sub check_category { + my $self = shift; + + return $self->{+_CATEGORY} if $self->{+_CATEGORY}; + + $self->_scan unless $self->{+_SCANNED}; + my $category = $self->{+_HEADERS}->{category}; + + return $category if $category; + + my $isolate = $self->check_feature(isolation => 0); + + # 'isolation' queue if isolation requested + return 'isolation' if $isolate; + + return 'general'; +} + +sub event_timeout { $_[0]->headers->{timeout}->{event} } +sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} } + +sub conflicts_list { + return $_[0]->headers->{conflicts} || []; # Assure conflicts is always an array ref. +} + +sub headers { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_HEADERS}; + return {%{$self->{+_HEADERS}}}; +} + +sub shbang { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_SHBANG}; + return {%{$self->{+_SHBANG}}}; +} + +sub switches { + my $self = shift; + + my $shbang = $self->shbang or return []; + my $switches = $shbang->{switches} or return []; + + return $switches; +} + +sub is_executable { + my $self = shift; + my ($file) = @_; + $file //= $self->{+FILE}; + return -x $file; +} + +sub scan { + my $self = shift; + $self->_scan(); + return; +} + +sub _scan { + my $self = shift; + + return if $self->{+_SCANNED}++; + return if $self->{+IS_BINARY}; + + my $fh = open_file($self->{+FILE}); + my $comment = $self->{+COMMENT} // '#'; + + my %headers; + for (my $ln = 1; my $line = <$fh>; $ln++) { + chomp($line); + next if $line =~ m/^\s*$/; + + if ($ln == 1 && $line =~ m/^#!/) { + my $shbang = $self->_parse_shbang($line); + if ($shbang) { + $self->{+_SHBANG} = $shbang; + + if ($shbang->{non_perl}) { + $self->{+NON_PERL} = 1; + + die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n" + unless $self->is_executable; + } + + next; + } + } + + # Uhg, breaking encapsulation between yath and the harness + if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) { + $headers{features}->{run} = 0; + next; + } + + next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/; # Ignore commented lines which aren't HARNESS-? + next if $line =~ m/^\s*(use|require|BEGIN|package)\b/; # Only supports single line BEGINs + last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/; + + my ($dir, $rest) = split /[-\s]+/, $1, 2; + $dir = lc($dir); + my @args; + if ($dir eq 'meta') { + @args = split /\s+/, $rest, 2; # Check for white space delimited + @args = split(/[-]+/, $rest, 2) if scalar @args == 1; # Check for dash delimited + $args[1] =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + } + elsif ($rest) { + $rest =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + @args = split /[-\s]+/, $rest; + } + + if ($dir eq 'no') { + my $feature = lc(join '_' => @args); + if ($feature eq 'retry') { + $headers{retry} = 0 + } else { + $headers{features}->{$feature} = 0; + } + } + elsif ($dir eq 'smoke') { + $headers{features}->{smoke} = 1; + } + elsif ($dir eq 'retry') { + $headers{retry} = 1 unless @args || defined $headers{retry}; + for my $arg (@args) { + if ($arg =~ m/^\d+$/) { + $headers{retry} = int $arg; + } + elsif ($arg =~ m/^iso/i) { + $headers{retry} //= 1; + $headers{retry_isolated} = 1; + } + else { + warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n"; + } + } + } + elsif ($dir eq 'yes' || $dir eq 'use') { + my $feature = lc(join '_' => @args); + $headers{features}->{$feature} = 1; + } + elsif ($dir eq 'stage') { + my ($name) = @args; + $headers{stage} = $name; + } + elsif ($dir eq 'meta') { + my ($key, $val) = @args; + $key = lc($key); + push @{$headers{meta}->{$key}} => $val; + } + elsif ($dir eq 'duration' || $dir eq 'dur') { + my ($name) = @args; + $name = lc($name); + $headers{duration} = $name; + } + elsif ($dir eq 'category' || $dir eq 'cat') { + my ($name) = @args; + $name = lc($name); + if ($name =~ m/^(long|medium|short)$/i) { + $headers{duration} = $name; + } + else { + $headers{category} = $name; + } + } + elsif ($dir eq 'conflicts') { + my @conflicts_array; + + foreach my $arg (@args) { + push @conflicts_array, lc($arg); + } + + # Allow multiple lines with # HARNESS-CONFLICTS FOO + $headers{conflicts} ||= []; + push @{$headers{conflicts}}, @conflicts_array; + + # Make sure no more than 1 conflict is ever present. + @{$headers{conflicts}} = uniq @{$headers{conflicts}}; + } + elsif ($dir eq 'timeout') { + my ($type, $num, $extra) = @args; + $type = lc($type); + $num = lc($num); + + ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit'; + + warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n" + unless $type =~ m/^(event|postexit)$/; + + $headers{timeout}->{$type} = $num; + } + elsif ($dir eq 'job' && $rest =~ m/slots\s+(\d+)(?:\s+(\d+))?$/i) { + $headers{min_slots} //= $1; + $headers{max_slots} //= $2 ? $2 : $1; + } + else { + warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n"; + } + } + + $self->{+_HEADERS} = \%headers; +} + +sub _parse_shbang { + my $self = shift; + my $line = shift; + + return {} if !defined $line; + + my %shbang; + + # NOTE: Test this, the dashes should be included with the switches + my $shbang_re = qr{ + ^ + \#!.*perl.*? # the perl path + (?: \s (-.+) )? # the switches, maybe + \s* + $ + }xi; + + if ($line =~ $shbang_re) { + my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; + $shbang{switches} = \@switches; + $shbang{line} = $line; + } + elsif ($line =~ m/^#!/ && $line !~ m/perl/i) { + $shbang{line} = $line; + $shbang{non_perl} = 1; + } + + return \%shbang; +} + +sub queue_item { + my $self = shift; + my ($job_name, $run_id, %inject) = @_; + + die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n" + unless $self->check_feature(run => 1); + + my $category = $self->check_category; + my $duration = $self->check_duration; + my $stage = $self->check_stage; + my $min_slots = $self->check_min_slots; + my $max_slots = $self->check_max_slots; + + my $smoke = $self->check_feature(smoke => 0); + my $fork = $self->check_feature(fork => 1); + my $preload = $self->check_feature(preload => 1); + my $timeout = $self->check_feature(timeout => 1); + my $stream = $self->check_feature(stream => 1); + my $io_events = $self->check_feature(io_events => 1); + + my $retry = $self->retry; + my $retry_isolated = $self->retry_isolated; + + my $binary = $self->{+IS_BINARY} ? 1 : 0; + my $non_perl = $self->{+NON_PERL} ? 1 : 0; + + my $et = $self->event_timeout; + my $pet = $self->post_exit_timeout; + + my $job_class = $self->job_class; + + my $input = $self->input; + my $test_args = $self->test_args; + + my $env_vars = $self->env_vars; + if ($env_vars) { + my $mix = delete $inject{env_vars}; + $env_vars = {%$mix, %$env_vars} if $mix; + } + + return { + binary => $binary, + category => $category, + conflicts => $self->conflicts_list, + duration => $duration, + file => $self->file, + rel_file => $self->relative, + job_id => gen_uuid(), + job_name => $job_name, + run_id => $run_id, + non_perl => $non_perl, + stage => $stage, + stamp => time, + switches => $self->switches, + use_fork => $fork, + use_preload => $preload, + use_stream => $stream, + use_timeout => $timeout, + smoke => $smoke, + io_events => $io_events, + rank => $self->rank, + + defined($input) ? (input => $input) : (), + defined($env_vars) ? (env_vars => $env_vars) : (), + defined($test_args) ? (test_args => $test_args) : (), + defined($job_class) ? (job_class => $job_class) : (), + defined($retry) ? (retry => $retry) : (), + defined($retry_isolated) ? (retry_isolated => $retry_isolated) : (), + defined($et) ? (event_timeout => $et) : (), + defined($pet) ? (post_exit_timeout => $self->post_exit_timeout) : (), + defined($min_slots) ? (min_slots => $min_slots) : (), + defined($max_slots) ? (max_slots => $max_slots) : (), + + @{$self->{+QUEUE_ARGS}}, + + %inject, + }; +} + +my %RANK = ( + smoke => 1, + immiscible => 10, + long => 20, + medium => 50, + short => 80, + isolation => 100, +); + +sub rank { + my $self = shift; + + return $RANK{smoke} if $self->check_feature('smoke'); + + my $rank = $RANK{$self->check_category}; + $rank ||= $RANK{$self->check_duration}; + $rank ||= 1; + + return $rank; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::TestFile - Abstraction of a test file and its meta-data. + +=head1 DESCRIPTION + +When Test2::Harness finds test files to run each one gets an instance of this +class to represent it. This class will scan test files to find important meta +data (binary vs script, inline harness directives, etc). The meta-data this +class can find helps yath decide when and how to run the test. + +If you write a custom L<Test2::Harness::Finder> or use some +L<Test2::Harness::Plugin> callbacks you may have to use, or even construct +instances of this class. + +=head1 SYNOPSIS + + use Test2::Harness::TestFile; + + my $tf = Test2::Harness::TestFile->new(file => "path/to/file.t"); + + # For an example 1, 1 works, but normally they are job_name and run_id. + my $meta_data = $tf->queue_item(1, 1); + + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $tf->file + +Set during object construction, and cannot be changed. + +=item $bool = $tf->is_binary + +Automatically set during construction, cannot be changed or set manually. + +=item $bool = $tf->non_perl + +Automatically set during construction, cannot be changed or set manually. + +=item $string = $tf->comment + +=item $tf->set_comment($string) + +Defaults to '#' can be set during construction, or changed if needed. + +This is used to tell yath what character(s) are used to denote a comment. This +is necessary for finding harness directives. In perl the '#' character is used, +and that is the default value. This is here to support non-perl tests. + +=item $class = $tf->job_class + +=item $tf->set_job_class($class) + +Default it undef (let the runner pick). You can change this if you want the +test to run with a custom job subclass. + +=item $arrayref = $tf->queue_args + +=item $tf->set_queue_args(\@ARGS) + +Key/Value pairs to append to the queue_item() data. + +=back + +=head1 METHODS + +=over 4 + +=item $cat = $tf->check_category() + +=item $tf->set_category($cat) + +This is how you find the category for a file. You can use C<set_category()> to +assign/override a category. + +=item $dur = $tf->check_duration() + +=item $tf->set_duration($dur) + +Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override +with C<set_duration()>. + +=item $stage = $tf->check_stage() + +=item $tf->set_stage($stage) + +Get the preload stage the test file thinks it should be run in. You can +override with C<set_stage()>. + +=item $bool = $tf->check_feature($name) + +This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or +C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES> +and C<USE> will result in a ture boolean. If no directive is found then +C<undef> will be returned. + +=item $arrayref = $tf->conflicts_list() + +Get a list of conflict markers. + +=item $seconds = $tf->event_timeout() + +If they test specifies an event timeout this will return it. + +=item %headers = $tf->headers() + +This returns the header data from the test file. + +=item $bool = $tf->is_executable() + +Check if the test file is executable or not. + +=item $data = $tf->meta($key) + +Get the meta-data for the specific key. + +=item $seconds = $tf->post_exit_timeout() + +If the test file has a custom post-exit timeout, this will return it. + +=item $hashref = $tf->queue_item($job_name, $run_id) + +This returns the data used to add the test file to the runner queue. + +=item $int = $tf->rank() + +Returns an integer value used to sort tests into an efficient run order. + +=item $path = $tf->relative() + +Relative path to the test file. + +=item $tf->scan() + +Scan the file and populate the header data. Return nothing, takes no arguments. +Automatically run by things that require the scan data. Results are cached. + +=item $tf->set_smoke($bool) + +Set smoke status. Smoke tests go to the front of the line when tests are +sorted. + +=item $hashref = $tf->shbang() + +Get data gathered from parsing the tests shbang line. + +=item $arrayref = $tf->switches() + +A list of switches passed to perl, usually from the shbang line. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util.pm b/bad/Test2/Harness/Util.pm new file mode 100644 index 000000000..8ab7bbf51 --- /dev/null +++ b/bad/Test2/Harness/Util.pm @@ -0,0 +1,635 @@ +package Test2::Harness::Util; +use strict; +use warnings; + +use Carp qw/confess/; +use Cwd qw/realpath/; +use List::Util qw/min/; +use Test2::Util qw/try_sig_mask do_rename/; +use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; +use File::Spec; + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + find_libraries + clean_path + + parse_exit + mod2file + file2mod + fqmod + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + lock_file + unlock_file + + hub_truth + + apply_encoding + + process_includes + + chmod_tmp + + looks_like_uuid + is_same_file + + resize_pipe +}; + +sub resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh, $size) = @_; + + # 1mb if we can + $size //= 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub is_same_file { + my ($file1, $file2) = @_; + + return 0 unless defined $file1; + return 0 unless defined $file2; + + return 1 if "$file1" eq "$file2"; + return 1 if clean_path($file1) eq clean_path($file2); + + return 0 unless -e $file1; + return 0 unless -e $file2; + + my ($dev1, $inode1) = stat($file1); + my ($dev2, $inode2) = stat($file2); + + return 0 unless $dev1 == $dev2; + return 0 unless $inode1 == $inode2; + return 1; +} + +sub looks_like_uuid { + my ($in) = @_; + + return undef unless defined $in; + return undef unless length($in) == 36; + return undef unless $in =~ m/^[0-9A-F\-]+$/i; + return $in; +} + +sub chmod_tmp { + my $file = shift; + + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; + + chmod($mode, $file); +} + +sub process_includes { + my %params = @_; + + my @start = @{delete $params{list} // []}; + + my @list; + my %seen = ('.' => 1); + + if (my $ch_dir = delete $params{ch_dir}) { + for my $path (@start) { + # '.' is special. + $seen{'.'}++ and next if $path eq '.'; + + if (File::Spec->file_name_is_absolute($path)) { + push @list => $path; + } + else { + push @list => File::Spec->catdir($ch_dir, $path); + } + } + } + else { + @list = @start; + } + + push @list => @INC if delete $params{include_current}; + + @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + + @list = grep { !$seen{$_}++ } @list; + + # If we ask for dot, or saw it during our processing, add it to the end. + push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; + + confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + + return @list; +} + +sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); +} + +sub parse_exit { + my ($exit) = @_; + + my $sig = $exit & 127; + my $dmp = $exit & 128; + + return { + sig => $sig, + err => ($exit >> 8), + dmp => $dmp, + all => $exit, + }; +} + +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return "$prefix\::$input"; +} + +sub hub_truth { + my ($f) = @_; + + return $f->{hubs}->[0] if $f->{hubs} && @{$f->{hubs}}; + return $f->{trace} if $f->{trace}; + return {}; +} + +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} + +sub read_file { + my ($file, @args) = @_; + + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); + + return $out; +} + +sub write_file { + my ($file, @content) = @_; + + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); + + return @content; +}; + +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; + + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); + + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } + } + + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} + +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} + +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} + +sub write_file_atomic { + my ($file, @content) = @_; + + my $pend = "$file.pend"; + + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; + + die $err unless $ok; + + return @content; +} + +sub lock_file { + my ($file, $mode) = @_; + + my $fh; + if (ref $file) { + $fh = $file; + } + else { + open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; + } + + for (1 .. 21) { + flock($fh, LOCK_EX) and last; + die "Could not lock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not lock file: $!"; + } + + return $fh; +} + +sub unlock_file { + my ($fh) = @_; + for (1 .. 21) { + flock($fh, LOCK_UN) and last; + die "Could not unlock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not unlock file: $!"; + } + + return $fh; +} + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub mod2file { + my ($mod) = @_; + confess "No module name provided" unless $mod; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + return $file; +} + +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; +} + + +sub find_libraries { + my ($search, @paths) = @_; + my @parts = grep $_, split /::(\*)?/, $search; + + @paths = @INC unless @paths; + + @paths = map { File::Spec->canonpath($_) } @paths; + + my %prefixes = map {$_ => 1} @paths; + + my @found; + my @bases = ([map { [$_ => length($_)] } @paths]); + while (my $set = shift @bases) { + my $new_base = []; + my $part = shift @parts; + + for my $base (@$set) { + my ($dir, $prefix) = @$base; + if ($part ne '*') { + my $path = File::Spec->catdir($dir, $part); + if (@parts) { + push @$new_base => [$path, $prefix] if -d $path; + } + elsif (-f "$path.pm") { + push @found => ["$path.pm", $prefix]; + } + + next; + } + + opendir(my $dh, $dir) or next; + for my $item (readdir($dh)) { + next if $item =~ m/^\./; + my $path = File::Spec->catdir($dir, $item); + if (@parts) { + # Sometimes @INC dirs are nested in eachother. + next if $prefixes{$path}; + + push @$new_base => [$path, $prefix] if -d $path; + next; + } + + next unless -f $path && $path =~ m/\.pm$/; + push @found => [$path, $prefix]; + } + } + + push @bases => $new_base if @$new_base; + } + + my %out; + for my $found (@found) { + my ($path, $prefix) = @$found; + + my @file_parts = File::Spec->splitdir(substr($path, $prefix)); + shift @file_parts if $file_parts[0] eq ''; + + my $file = join '/' => @file_parts; + $file_parts[-1] = substr($file_parts[-1], 0, -3); + my $module = join '::' => @file_parts; + + $out{$module} //= $file; + } + + return \%out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util - General utiliy functions. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 MISC + +=over 4 + +=item apply_encoding($fh, $enc) + +Apply the specified encoding to the filehandle. + +B<Justification>: +L<PERLBUG 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923> +If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in +order to avoid the thread segfault. + +This is a reusable implementation of this: + + sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); + } + +=item $clean = clean_path($path) + +Take a file path and clean it up to a minimal absolute path if possible. Always +returns a path, but if it cannot be cleaned up it is unchanged. + +=item $hashref = find_libraries($search) + +=item $hashref = find_libraries($search, @paths) + +C<@INC> is used if no C<@paths> are provided. + +C<$search> should be a module name with C<*> wildcards replacing sections. + + find_libraries('Foo::*::Baz') + find_libraries('*::Bar::Baz') + find_libraries('Foo::Bar::*') + +These all look for modules matching the search, this is a good way to find +plugins, or similar patterns. + +The result is a hashref of C<< { $module => $path } >>. If a module exists in +more than 1 search path the first is used. + +=item $mod = fqmod($prefix, $mod) + +This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If +C<$mod> starts with the C<'+'> character the character will be removed and the +result returned without prepending C<$prefix>. + +=item hub_truth + +This is an internal implementation detail, do not use it. + +=item $hashref = parse_exit($?) + +This parses the exit value as typically stored in C<$?>. + +Resulting hash: + + { + sig => ($? & 127), # Signal value if the exit was caused by a signal + err => ($? >> 8), # Actual exit code, if any. + dmp => ($? & 128), # Was there a core dump? + all => $?, # Original exit value, unchanged + } + + +=item @list = process_includes(%PARAMS) + +This method will build up a list of include dirs fit for C<@INC>. The returned +list should contain only unique values, in proper order. + +Params: + +=over 4 + +=item list => \@START + +Paths to start the new list. + +Optional. + +=item ch_dir => $path + +Prefix to prepend to all paths in the C<list> param. No effect without an +initial list. + +=item include_current => $bool + +This will add all paths from C<@INC> to the output, after the initial list. +Note that '.', if in C<@INC> will be moved to the end of the final output. + +=item clean => $bool + +If included all paths except C<'.'> will be cleaned using C<clean_path()>. + +=item include_dot => $bool + +If true C<'.'> will be appended to the end of the output. + +B<Note> even if this is set to false C<'.'> may still be included if it was in +the initial list, or if it was in C<@INC> and C<@INC> was included using the +C<include_current> parameter. + +=back + +=back + +=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION + +These convert between module names like C<Foo::Bar> and filenames like +C<Foo/Bar.pm>. + +=over 4 + +=item $file = mod2file($mod) + +=item $mod = file2mod($file) + +=back + +=head2 FOR READING/WRITING FILES + +=over 4 + +=item $fh = open_file($path, $mode) + +=item $fh = open_file($path) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = read_file($file) + +This will open the file at C<$path> and return all its contents. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $fh = maybe_open_file($path) + +=item $fh = maybe_open_file($path, $mode) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +C<undef> is returned if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = maybe_read_file($path) + +This will open the file at C<$path> and return all its contents. + +This will return C<undef> if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item @content = write_file($path, @content) + +Write content to the specified file. This will open the file with mode +C<< '>' >>, write the content, then close the file. + +An exception will be thrown if any part fails. + +=item @content = write_file_atomic($path, @content) + +This will open a temporary file, write the content, close the file, then rename +the file to the desired C<$path>. This is essentially an atomic write in that +C<$file> will not exist until all content is written, preventing other +processes from doing a partial read while C<@content> is being written. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/File.pm b/bad/Test2/Harness/Util/File.pm new file mode 100644 index 000000000..6a19341f1 --- /dev/null +++ b/bad/Test2/Harness/Util/File.pm @@ -0,0 +1,256 @@ +package Test2::Harness::Util::File; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IO::Handle; + +use Test2::Harness::Util(); + +use Carp qw/croak confess/; +use Fcntl qw/SEEK_SET SEEK_CUR/; + +use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos <skip_bad_decode }; + +sub exists { -e $_[0]->{+NAME} } + +sub decode { shift; $_[0] } +sub encode { shift; $_[0] } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+_INIT_FH} = delete $self->{fh}; +} + +sub open_file { + my $self = shift; + return Test2::Harness::Util::open_file($self->{+NAME}, @_) +} + +sub maybe_read { + my $self = shift; + return undef unless -e $self->{+NAME}; + return $self->read; +} + +sub read { + my $self = shift; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +sub rewrite { + my $self = shift; + return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); +} + +sub write { + my $self = shift; + return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); +} + +sub reset { + my $self = shift; + delete $self->{+_FH}; + delete $self->{+DONE}; + delete $self->{+LINE_POS}; + return; +} + +sub fh { + my $self = shift; + return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; + + # Remove any other PID handles + $self->{+_FH} = {}; + + if (my $fh = $self->{+_INIT_FH}) { + $self->{+_FH}->{$$} = $fh; + } + else { + $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; + } + + $self->{+_FH}->{$$}->blocking(0); + return $self->{+_FH}->{$$}; +} + +sub read_line { + my $self = shift; + my %params = @_; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; + seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" + if eof($fh) || tell($fh) != $pos; + + my $line = <$fh>; + + # No line, nothing to do + return unless defined $line && length($line); + + # Partial line, hold off unless done + return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; + + my $new_pos = tell($fh); + die "Failed to 'tell': $!" if $new_pos == -1; + + my $err = 0; + local $@; + unless (eval { $line = $self->decode($line); 1 }) { + $err = $@ // 'error'; + confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; + warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; + $line = undef; + } + + $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; + return $line unless wantarray; + return ($pos, $new_pos, $line, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File - Utility class for manipulating a file. + +=head1 DESCRIPTION + +This is a utility class for file operations. This also serves as a base class +for several file helpers. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File; + + my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); + + $f->write($content); + + my $fh = $f->open_file('<'); + + # Read, throw exception if it cannot read + my $content = $f->read(); + + # Try to read, but do not throw an exception if it cannot be read. + my $content_or_undef = $f->maybe_read(); + + my $line1 = $f->read_line(); + my $line2 = $f->read_line(); + ... + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $f->name; + +Get the filename. Must also be provided during construction. + +=item $bool = $f->done; + +True if read_line() has read every line. + +=back + +=head1 METHODS + +=over 4 + +=item $decoded = $f->decode($encoded) + +This is a no-op, it returns the argument unchanged. This is called by C<read> +and C<read_line>. Subclasses can override this if the file contains encoded +data. + +=item $encoded = $f->encode($decoded) + +This is a no-op, it returns the argument unchanged. This is called by C<write>. +Subclasses can override this if the file contains encoded data. + +=item $bool = $f->exists() + +Check if the file exists + +=item $content = $f->maybe_read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will return undef. + +=item $fh = $f->open_file() + +=item $fh = $f->open_file($mode) + +Open a handle to the file. If no $mode is provided C<< '<' >> is used. + +=item $content = $f->read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will throw an exception. + +=item $line = $f->read_line() + +Read a single line from the file, subsequent calls will read the next line and +so on until the end of the file is reached. Reset with the C<reset()> method. + +=item $f->reset() + +Reset the internal line iterator used by C<read_line()>. + +=item $f->write($content) + +This is an atomic-write. First $content will be written to a temporary file +using C<< '>' >> mode. Then the temporary file will be renamed to the desired +file name. Under the hood this uses C<write_file_atomic()> from +L<Test2::Harness::Util>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/File/JSON.pm b/bad/Test2/Harness/Util/File/JSON.pm new file mode 100644 index 000000000..f3f6c5a1e --- /dev/null +++ b/bad/Test2/Harness/Util/File/JSON.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSON; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/pretty/; + +sub decode { shift; decode_json(@_) } +sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } + +sub reset { croak "line reading is disabled for json files" } +sub read_line { croak "line reading is disabled for json files" } + +sub maybe_read { + my $self = shift; + + return undef unless -e $self->{+NAME}; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + return undef unless defined($out) && length($out); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSON - Utility class for a JSON file. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> which automatically handles +encoding/decoding JSON data. + +=head1 SYNOPSIS + + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); + + $hash = $file->read; + # or + $$file->write({...}); + +=head1 SEE ALSO + +See the base class L<Test2::Harness::Util::File> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/File/JSONL.pm b/bad/Test2/Harness/Util/File/JSONL.pm new file mode 100644 index 000000000..ce64c51b3 --- /dev/null +++ b/bad/Test2/Harness/Util/File/JSONL.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSONL; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::Util::File::Stream'; +use Test2::Harness::Util::HashBase; + +sub decode { shift; decode_json($_[0]) } +sub encode { shift; encode_json(@_) . "\n" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> which automatically handles +encoding/decoding JSONL data. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + while (1) { + my @items = $jsonl->poll(max => 1000) or last; + for my $item (@items) { + ... handle $item ... + } + } + +or + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + $jsonl->write({my => 'item', ... }); + ... + +=head1 SEE ALSO + +See the base classes L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/File/Stream.pm b/bad/Test2/Harness/Util/File/Stream.pm new file mode 100644 index 000000000..6a526a4b6 --- /dev/null +++ b/bad/Test2/Harness/Util/File/Stream.pm @@ -0,0 +1,218 @@ +package Test2::Harness::Util::File::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/lock_file unlock_file/; +use Fcntl qw/SEEK_SET/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/use_write_lock -tail +_wfh +_wpid/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + my $tail = $self->{+TAIL} or return; + + return unless $self->exists; + + my @lines = $self->poll_with_index; + if (@lines < $self->{+TAIL}) { + $self->seek(0); + } + else { + $self->seek($lines[0 - $tail]->[0]); + } +} + +sub poll_with_index { + my $self = shift; + my %params = @_; + + my $max = delete $params{max} || 0; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my @out; + while (!$max || @out < $max) { + my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); + last unless defined($line) || defined($spos) || defined($epos) || $err; + + $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; + push @out => [$spos, $epos, $line] unless $err; + $pos = $epos; + } + + return @out; +} + +sub read { + my $self = shift; + + return $self->poll(from => 0); +} + +sub poll { + my $self = shift; + my @lines = $self->poll_with_index(@_); + return map { $_->[-1] } @lines; +} + +sub write { + my $self = shift; + + my $name = $self->{+NAME}; + + my $fh; + if ($self->{+USE_WRITE_LOCK}) { + $fh = lock_file($self->name, '>>'); + $fh->autoflush(1); + } + else { + unless ($self->{+_WPID} && $self->{+_WPID} == $$) { + delete $self->{+_WFH}; + $self->{+_WPID} = $$; + } + + if ($fh = $self->{+_WFH}) { + seek($fh, 2, 0); + } + else { + $fh = $self->{+_WFH} = Test2::Harness::Util::open_file($self->name, '>>'); + $fh->autoflush(1); + } + } + + print {$fh} $self->encode($_) for @_; + + if ($self->{+USE_WRITE_LOCK}) { + unlock_file($fh); + close($fh) or die "Could not close file '$name': $!"; + } + + return @_; +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + my $fh = $self->fh; + my $name = $self->{+NAME}; + + seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; + $self->{+LINE_POS} = $pos; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Stream - Utility class for manipulating a file that +serves as an output stream. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::File> that streams the contents of a file, even +if the file is still being written. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Stream; + + my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); + + # Read some lines + my @lines = $stream->poll; + + ... + + # Read more lines, if any. + push @lines => $stream->poll; + +=head1 ATTRIBUTES + +See L<Test2::Harness::File> for additional attributes. + +These can be passed in as construction arguments if desired. + +=over 4 + +=item $bool = $stream->use_write_lock + +=item $stream->use_write_lock($bool) + +Lock the file for every C<write()> operation. + +=item $bool = $stream->tail + +Start near the end of the file and only poll for updates appended to it. + +=back + +=head1 METHODS + +See L<Test2::Harness::File> for additional methods. + +=over 4 + +=item @lines = $stream->read() + +Read all lines from the beginning. Every time it is called it returns ALL lines. + +=item @lines = $stream->poll() + +=item @lines = $stream->poll(max => $int) + +Poll for lines. This is an iterator, it should not return the same line more +than once, you can call it multiple times to get any additional lines that have +been added since the last poll. + +=item $stream->write(@content) + +Append @content to the file. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/File/Value.pm b/bad/Test2/Harness/Util/File/Value.pm new file mode 100644 index 000000000..bf291ba5b --- /dev/null +++ b/bad/Test2/Harness/Util/File/Value.pm @@ -0,0 +1,100 @@ +package Test2::Harness::Util::File::Value; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + $self->{+DONE} = 1; +} + +sub read { + my $self = shift; + my $out = $self->SUPER::read(@_); + chomp($out) if defined $out; + return $out; +} + +sub read_line { + my $self = shift; + my $out = $self->SUPER::read_line(@_); + chomp($out) if defined $out; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Value - Utility class for a file that contains +exactly 1 value. + +=head1 DESCRIPTION + +This is a subclass of L<Test2::Harness::Util::File> for files expected to have +exactly 1 value stored in them. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Value; + + my $vf = Test2::Harness::Util::File::Value->new(name => 'path/to/file'); + my $val = $vf->read; + +=head1 METHODS + +=over 4 + +=item $val = $vf->read() + +Read all contents from the file, C<chomp()> it, and return it. + +=item $val = $vf->read_line() + +Read the first line from the file, C<chomp()> it, and return it. Note, this +may not return anything if the value in the file does not terminate with a +newline. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/HashBase.pm b/bad/Test2/Harness/Util/HashBase.pm new file mode 100644 index 000000000..0146e1c7c --- /dev/null +++ b/bad/Test2/Harness/Util/HashBase.pm @@ -0,0 +1,473 @@ +package Test2::Harness::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.008'; + *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub import { + my $class = shift; + my $into = caller; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; + $Test2::Harness::Util::HashBase::VERSION{$into} = $ver if !$Test2::Harness::Util::HashBase::VERSION{$into} || $Test2::Harness::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Harness::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Harness::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Harness::Util::HashBase>. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Harness::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B<Note:> Test2::Harness::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Harness::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'s key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Harness::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Harness::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Harness::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Harness::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Harness::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Harness::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Harness::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Harness::Util::HashBase class. + +=over 4 + +=item @list = Test2::Harness::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Harness::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/IPC.pm b/bad/Test2/Harness/Util/IPC.pm new file mode 100644 index 000000000..88e45a35f --- /dev/null +++ b/bad/Test2/Harness/Util/IPC.pm @@ -0,0 +1,326 @@ +package Test2::Harness::Util::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Cwd qw/getcwd/; +use Config qw/%Config/; +use Test2::Util qw/CAN_REALLY_FORK/; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + USE_P_GROUPS + run_cmd + swap_io +}; + +BEGIN { + if ($Config{'d_setpgrp'}) { + *USE_P_GROUPS = sub() { 1 }; + } + else { + *USE_P_GROUPS = sub() { 0 }; + } +} + +if (CAN_REALLY_FORK) { + *run_cmd = \&_run_cmd_fork; +} +else { + *run_cmd = \&_run_cmd_spwn; +} + +sub swap_io { + my ($fh, $to, $die, $mode) = @_; + + $die ||= sub { + my @caller = caller; + my @caller2 = caller(1); + die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); + }; + + my $orig_fd; + if (ref($fh) eq 'ARRAY') { + ($orig_fd, $fh) = @$fh; + } + else { + $orig_fd = fileno($fh); + } + + $die->("Could not get original fd ($fh)") unless defined $orig_fd; + + if (ref($to)) { + $mode //= $orig_fd ? '>&' : '<&'; + open($fh, $mode, $to) or $die->("Could not redirect output: $!"); + } + else { + $mode //= $orig_fd ? '>' : '<'; + open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); + } + + return if fileno($fh) == $orig_fd; + + $die->("New handle does not have the desired fd!"); +} + +sub _run_cmd_fork { + my %params = @_; + + my $cmd = $params{command} or die "No 'command' specified"; + + my $pid = fork; + die "Failed to fork" unless defined $pid; + if ($pid) { + $_->() for @{$params{run_in_parent} // []}; + return $pid; + } + else { + $_->() for @{$params{run_in_child} // []}; + } + %ENV = (%ENV, %{$params{env}}) if $params{env}; + setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp}; + + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + if (my $dir = $params{chdir} // $params{ch_dir}) { + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDERR, $stderr, $die) if $stderr; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + swap_io(\*STDIN, $stdin, $die) if $stdin; + open(STDIN, "<", "/dev/null") if !$stdin; + + @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd; + + exec(@$cmd) or $die->("Failed to exec!"); +} + +sub _run_cmd_spwn { + my %params = @_; + + local %ENV = (%ENV, %{$params{env}}) if $params{env}; + + my $cmd = $params{command} or die "No 'command' specified"; + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + my $cwd; + if (my $dir = $params{chdir} // $params{ch_dir}) { + $cwd = getcwd(); + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDIN, '<&', \*STDIN) or die "Could not clone STDIN: $!"; + open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!"; + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $stdin, $die) if $stdin; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + $stdin ? swap_io(\*STDIN, $stdin, $die) : close(STDIN); + + local $?; + my $pid; + my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd }; + my $bad = $?; + my $err = $@; + + swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die); + swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr; + swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout; + + if ($cwd) { + chdir($cwd) or die "Could not chdir: $!"; + } + + die $err unless $ok; + die "Spawn resulted in code $bad" if $bad && $bad != $pid; + die "Failed to spawn" unless $pid; + + $_->() for @{$params{run_in_parent} // []}; + + return $pid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::IPC - Utilities for IPC management. + +=head1 DESCRIPTION + +This package provides low-level IPC tools for Test2::Harness. + +=head1 EXPORTS + +All exports are optional and must be specified at import time. + +=over 4 + +=item $bool = USE_P_GROUPS() + +This is a shortcut for: + + use Config qw/%Config/; + $Config{'d_setpgrp'}; + +=item swap_io($from, $to) + +=item swap_io($from, $to, \&die) + +This will close and re-open the file handle designated by C<$from> so that it +redirects to the handle specified in C<$to>. It preserves the file descriptor +in the process, and throws an exception if it fails to do so. + + swap_io(\*STDOUT, $fh); + # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'. + +As long as the file descriptor is greater than 0 it will open for writing. If +the descriptor is 0 it will open for reading, allowing for a swap of C<STDIN> +as well. + +Extra effort is made to insure errors go to the real C<STDERR>, specially when +trying to swap out C<STDERR>. If you have trouble with this, or do not trust +it, you can provide a custom coderef as a third argument, this coderef will be +used instead of C<die()> to throw exceptions. + +Note that the custom die logic when you do not provide your own bypasses the +exception catching mechanism and will exit your program. If this is not +desirable then you should provide a custom die subref. + +=item $pid = run_cmd(command => [...], %params) + +This function will run the specified command and return a pid to you. When +possible this will be done via C<fork()> and C<exec()>. When that is not +possible it uses the C<system(1, ...)> trick to spawn a new process. Some +parameters do not work in the second case, and are silently ignored. + +Parameters: + +=over 4 + +=item command => [$command, sub { ... }, @args] + +=item command => sub { return ($command, @args) } + +This parameter is required. This should either be an arrayref of arguments for +C<exec()>, or a coderef that returns a list of arguments for C<exec()>. On +systems without fork/exec the arguments will be passed to +C<system(1, $command, @args)> instead. + +If the command arrayref has a coderef in it, the coderef will be run and its +return value(s) will be inserted in its place. This replacement happens +post-chroot + +=item run_in_parent => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the parent process immedietly after the +child process is started. + +=item run_in_child => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the child process immedietly after fork. +This parameter is silently ignored on systems without fork/exec. + +=item env => { ENVVAR => $VAL, ... } + +A hashref of custom environment variables to set in the child process. In the +fork/exec model this is done post-fork, in the spawn model this is done via +local prior to the spawn. + +=item no_set_pgrp => $bool, + +Normall C<setpgrp(0,0)> is called on systems where it is supported. You can use +this parameter to override the normal behavior. setpgrp() is not called in the +spawn model, so this parameter is silently ignored there. + +=item chdir => 'path/to/dir' + +=item ch_dir => 'path/to/dir' + +chdir() to the specified directory for the new process. In the fork/exec model +this is done post-fork in the child. In the spawn model this is done before the +spawn, then a second chdir() puts the parent process back to its original dir +after the spawn. + +=item stdout => $handle + +=item stderr => $handle + +=item stdin => $handle + +Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec +model these are swapped into place post-fork in the child. In the spawn model +the swap occurs pre-spawn, then the old handles are swapped back post-spawn. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/JSON.pm b/bad/Test2/Harness/Util/JSON.pm new file mode 100644 index 000000000..2c73ec443 --- /dev/null +++ b/bad/Test2/Harness/Util/JSON.pm @@ -0,0 +1,263 @@ +package Test2::Harness::Util::JSON; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +BEGIN { + local $@ = undef; + my $ok = eval { + require JSON::MaybeXS; + JSON::MaybeXS->import('JSON'); + 1; + + if (JSON() eq 'JSON::PP') { + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + elsif (JSON() eq 'JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 1 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + elsif (JSON() eq 'Cpanel::JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 1 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + }; + + unless ($ok) { + require JSON::PP; + *JSON = sub() { 'JSON::PP' }; + + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + +} + +our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; +our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); +my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); + +sub encode_json { $json->encode(@_) } +sub encode_canon_json { $canon->encode(@_) } +sub encode_pretty_json { $pretty->encode(@_) } + +sub decode_json { + my ($input) = @_; + my $data; + + local $@; + my $error; + + # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally + # testing bytes behavior we need to accept the bytes from the JSON file instead. + my $ok = eval { $data = $json->decode($input); 1 } || do { + $error = $@; + eval { $data = $json_non_utf8->decode($input); 1 }; + }; + $error ||= $@; + return $data if $ok; + my $mess = Carp::longmess("JSON decode error: $error"); + die "$mess\n=======\n$input\n=======\n"; +} + +sub stream_json_l { + my ($path, $handler, %params) = @_; + + croak "No path provided" unless $path; + + return stream_json_l_file($path, $handler) if -f $path; + return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; + + croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; +} + +sub stream_json_l_file { + my ($path, $handler) = @_; + + croak "Invalid file '$path'" unless -f $path; + + croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." + unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; + + if ($1 eq 'json') { + require Test2::Harness::Util::File::JSON; + my $json = Test2::Harness::Util::File::JSON->new(name => $path); + $handler->($json->read); + } + else { + require Test2::Harness::Util::File::JSONL; + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); + while (my ($item) = $jsonl->poll(max => 1)) { + $handler->($item); + } + } + + return 1; +} + +sub stream_json_l_url { + my ($path, $handler, %params) = @_; + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args} // []; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + my $buffer = ''; + my $iterate = sub { + my ($res) = @_; + + my @parts = split /(\n)/, $buffer; + + while (@parts > 1) { + my $line = shift @parts; + my $nl = shift @parts; + my $data; + unless (eval { $data = decode_json($line); 1 }) { + warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; + next; + } + + $handler->($data, $res); + } + + $buffer = shift @parts // ''; + }; + + my $res = $ht->$meth( + $path, + { + @$args, + data_callback => sub { + my ($chunk, $res) = @_; + $buffer .= $chunk; + $iterate->($res); + }, + } + ); + + if (length($buffer)) { + $buffer .= "\n" unless $buffer =~ m/\n$/; + $iterate->($res); + } + + return $res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best +JSON implementation. + +=head1 DESCRIPTION + +This package provides functions for encoding/decoding json, and uses the best +json tools available. + +=head1 SYNOPSIS + + use Test2::Harness::Util::JSON qw/encode_json decode_json/; + + my $data = { foo => 1 }; + my $json = encode_json($data); + my $copy = decode_json($json); + +=head1 EXPORTS + +=over 4 + +=item $package = JSON() + +This returns the JSON package being used by yath. + +=item $bool = JSON_IS_PP() + +True if yath is using L<JSON::PP>. + +=item $bool = JSON_IS_XS() + +True if yath is using L<JSON::XS>. + +=item $bool = JSON_IS_CPANEL() + +True if yath is using L<Cpanel::JSON::XS>. + +=item $bool = JSON_IS_CPANEL_OR_XS() + +True if either L<JSON::XS> or L<Cpanel::JSON::XS> are being used. + +=item $string = encode_json($data) + +Encode data into json. String will be 1-line. + +=item $data = decode_json($string) + +Decode json data from the string. + +=item $string = encode_pretty_json($data) + +Encode into human-friendly json. + +=item $string = encode_canon_json($data) + +Encode into canon-json. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/Queue.pm b/bad/Test2/Harness/Util/Queue.pm new file mode 100644 index 000000000..efe7289b3 --- /dev/null +++ b/bad/Test2/Harness/Util/Queue.pm @@ -0,0 +1,213 @@ +package Test2::Harness::Util::Queue; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/write_file_atomic/; + +use Test2::Harness::Util::File::JSONL(); + +use Test2::Harness::Util::HashBase qw{ + -file -qh -ended +}; + +sub init { + my $self = shift; + + croak "'file' is a required attribute" + unless $self->{+FILE}; +} + +sub start { + my $self = shift; + write_file_atomic($self->{+FILE}, ""); +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + $self->{+QH}->seek($pos); + + return $pos; +} + +sub reset { + my $self = shift; + delete $self->{+QH}; +} + +sub poll { + my $self = shift; + my $max = shift; + + return $self->{+ENDED} if $self->{+ENDED}; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + my @out = $self->{+QH}->poll_with_index( $max ? (max => $max) : () ); + + $self->{+ENDED} = $out[-1] if @out && !defined($out[-1]->[-1]); + + return @out; +} + +sub end { + my $self = shift; + $self->_enqueue(undef); +} + +sub enqueue { + my $self = shift; + my ($task) = @_; + + croak "Invalid task" + unless $task && ref($task) eq 'HASH' && values %$task; + + $task->{stamp} ||= time; + + $self->_enqueue($task); +} + +sub _enqueue { + my $self = shift; + my ($task) = @_; + + my $fh = Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}, use_write_lock => 1); + $fh->write($task); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Queue - Representation of a queue. + +=head1 DESCRIPTION + +This module represents a queue, stored as a jsonl file. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + $queue->start(); # Create the queue + + $queue->enqueue({foo => 'bar', baz => 'bat'}); + $queue->enqueue({foo => 'bar2', baz => 'bat2'}); + ... + + $queue->end(); + +Then in another processs: + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + my @items; + while (1) { + @items = $queue->poll(); + while (@items) { + my $item = shift @items or last; + + ... process $item + } + + # Queue ends with an 'undef' entry + last if @items && !defined($items[0]); + } + +=head1 METHODS + +=over 4 + +=item $path = $queue->file + +The filename used for the queue + +=back + +=head2 READING + +=over 4 + +=item $queue->reset() + +Restart reading the queue. + +=item @items = $queue->poll() + +Get more items from the queue. May need to call it multiple times, specially if +another process is still writing to the queue. + +Returns an empty list if no items are available yet. + +Returns 'undef' to terminate the list. + +=item $bool = $queue->ended() + +Check if the queue has ended. + +=back + +=head1 WRITING + +=over 4 + +=item $queue->start() + +Open the queue file for writing. + +=item $queue->enqueue(\%HASHREF) + +Add an item to the queue. + +=item $queue->end() + +Terminate the queue. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/Term.pm b/bad/Test2/Harness/Util/Term.pm new file mode 100644 index 000000000..da0b6a306 --- /dev/null +++ b/bad/Test2/Harness/Util/Term.pm @@ -0,0 +1,104 @@ +package Test2::Harness::Util::Term; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; + +use Importer Importer => 'import'; +our @EXPORT_OK = qw/USE_ANSI_COLOR/; + +{ + my $use = 0; + local ($@, $!); + + if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { + if (IS_WIN32) { + if (eval { require Win32::Console::ANSI }) { + Win32::Console::ANSI->import(); + $use = 1; + } + } + else { + $use = 1; + } + } + + if ($use) { + *USE_ANSI_COLOR = sub() { 1 }; + } + else { + *USE_ANSI_COLOR = sub() { 0 }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Term - Terminal utilities for Test2::Harness + +=head1 DESCRIPTION + +This module provides information about the terminal in which the harness is +running. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + + if (USE_ANSI_COLOR) { + ... + } + else { + ... + } + +=head1 EXPORTS + +=over 4 + +=item $bool = USE_ANSI_COLOR() + +True if L<Term::ANSIColor> is available and usable. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/bad/Test2/Harness/Util/UUID.pm b/bad/Test2/Harness/Util/UUID.pm new file mode 100644 index 000000000..459bea92e --- /dev/null +++ b/bad/Test2/Harness/Util/UUID.pm @@ -0,0 +1,85 @@ +package Test2::Harness::Util::UUID; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Data::UUID; +use Importer 'Importer' => 'import'; + +our @EXPORT = qw/gen_uuid/; +our @EXPORT_OK = qw/UG gen_uuid/; + +my ($UG, $UG_PID); +sub UG { + return $UG if $UG && $UG_PID && $UG_PID == $$; + + $UG_PID = $$; + return $UG = Data::UUID->new; +} + +sub gen_uuid { UG()->create_str() } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::UUID - Utils for generating UUIDs. + +=head1 DESCRIPTION + +This module provides a consistent UUID source for all of Test2::Harness. + +=head1 SYNOPSIS + + use Test2::Harness::Util::UUID qw/gen_uuid/; + + my $uuid = gen_uuid; + +=head1 EXPORTS + +=over 4 + +=item $uuid = gen_uuid() + +Generate a UUID. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib/Test2/Tools/HarnessTester.pm b/bad/Test2/Tools/HarnessTester.pm similarity index 100% rename from lib/Test2/Tools/HarnessTester.pm rename to bad/Test2/Tools/HarnessTester.pm diff --git a/demo.pl b/demo.pl new file mode 100755 index 000000000..813a6abb2 --- /dev/null +++ b/demo.pl @@ -0,0 +1,106 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Tickit::Console; +use Tickit::Widgets 0.30 qw( Frame=0.32 ); + +use String::Tagged; + +my $globaltab; + +# Input History State +my $idx = -1; +my $set; +my @log; +my $console = Tickit::Console->new( + on_line => sub { + my ($self, $line) = @_; + + $idx = -1; + $set = undef; + + if ($line eq "quit") { + exit(0); + } + else { + unshift @log => $line; + $globaltab->add_line("<INPUT>: $line"); + } + }, +); + +$console->bind_key( + "Tab" => sub { + my ($c, $key) = @_; + + my $t = $c->find_child('first', undef, where => sub { $_ && $_->isa('Tickit::Widget::Entry') }); + my $p = $t->make_popup_at_cursor(0, 0, 100, 100); + + use Tickit::Widget::Frame; + use Tickit::Widget::Static; + my $frame = Tickit::Widget::Frame->new( + style => {linetype => "single"}, + ); + + $frame->set_child(Tickit::Widget::Static->new( + text => "Hello, world", + align => "centre", + valign => "middle", + )); + + $frame->set_window($p); + + use Data::Dumper; + local $Data::Dumper::Maxdepth = 2; + print Dumper($c); + } +); + +# New up/down +$console->bind_key("M-Up" => sub { shift->active_tab->widget->scroll(-1) }); +$console->bind_key("M-Down" => sub { shift->active_tab->widget->scroll(1) }); + +# History Up +$console->bind_key("Up" => sub { + my $c = shift; + + my $e = $c->find_child('first', undef, where => sub { $_ && $_->isa('Tickit::Widget::Entry') }); + + if ($idx == -1) { + $set //= $e->text // ''; + $e->key_end_of_line; + } + + if ($log[$idx + 1]) { + $idx++; + $e->set_text($log[$idx]); + $e->key_end_of_line; + } +}); + +# History Down +$console->bind_key("Down" => sub { + my $c = shift; + + my $e = $c->find_child('first', undef, where => sub { $_ && $_->isa('Tickit::Widget::Entry') }); + + return if $idx < 0; + $idx--; + + if ($idx < 0) { + $idx = -1; + $e->set_text($set // ''); + $e->key_end_of_line; + $set = undef; + } + else { + $e->set_text($log[$idx]); + $e->key_end_of_line; + } +}); + +$globaltab = $console->add_tab(name => "GLOBAL"); + +Tickit->new(root => $console)->run; diff --git a/foo_command.pm b/foo_command.pm new file mode 100644 index 000000000..a52855550 --- /dev/null +++ b/foo_command.pm @@ -0,0 +1,19 @@ +package App::Yath::Command::foo; +use strict; +use warnings; + +use parent 'App::Yath::Command'; + +sub name { 'foo' } + +sub description { "Hi There!" } + +use Getopt::Yath; + +option_group {category => 'Foo Options', group => 'foo'} => sub { + option foo => ( type => 'Bool' ); + option bar => ( type => 'Bool' ); + option baz => ( type => 'Bool' ); +}; + +1; diff --git a/lib/Test2/Harness/IPC/Protocol/IPSocket.pm b/lib/Test2/Harness/IPC/Protocol/IPSocket.pm new file mode 100644 index 000000000..e69de29bb diff --git a/lib/Test2/Harness/IPC/Protocol/UnixSocket.pm b/lib/Test2/Harness/IPC/Protocol/UnixSocket.pm new file mode 100644 index 000000000..e69de29bb diff --git a/lib2.0/App/Yath.pm b/lib2.0/App/Yath.pm new file mode 100644 index 000000000..b5b344de0 --- /dev/null +++ b/lib2.0/App/Yath.pm @@ -0,0 +1,982 @@ +package App::Yath; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + <config + <settings + +options + + <argv + <orig_argv + <env_vars + + <command +}; + +use Getopt::Yath(); +use Getopt::Yath::Settings; +use Getopt::Yath::Term qw/color fit_to_width/; + +use App::Yath::Options::Yath; + +use Time::HiRes qw/time/; + +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries clean_path mod2file/; +use Test2::Harness::Util::JSON qw/encode_pretty_json/; + +use Scalar::Util qw/blessed/; + +my $APP_PATH = __FILE__; +$APP_PATH =~ s{App\S+Yath\.pm$}{}g; +$APP_PATH = clean_path($APP_PATH); +sub app_path { $APP_PATH } + +sub init { + my $self = shift; + + my $old = select STDOUT; + $| = 1; + select STDERR; + $| = 1; + select $old; + + $self->{argv} //= []; + $self->{+ENV_VARS} //= {}; + $self->{+CONFIG} //= {}; + $self->{+SETTINGS} //= Getopt::Yath::Settings->new; + $self->{+ORIG_ARGV} = [@{$self->argv}]; +} + +sub cli_help { + my $self = shift; + my ($options, %params) = @_; + + my $cmd_class = $self->command; + + $options //= $self->options; + my $cmd = $cmd_class ? $cmd_class->name : 'COMMAND'; + + my $help = ""; + if ($cmd_class) { + if (color()) { + $help .= "\n"; + $help .= Term::ANSIColor::color('bold white') . "Command selected: "; + $help .= Term::ANSIColor::color('reset'); + $help .= Term::ANSIColor::color('bold green') . $cmd; + $help .= Term::ANSIColor::color('reset'); + $help .= Term::ANSIColor::color('yellow') . " ($cmd_class)\n\n"; + $help .= Term::ANSIColor::color('reset'); + } + else { + $help .= "\nCommand selected: $cmd ($cmd_class)\n"; + } + + my @desc = map { fit_to_width(" ", $_) } split /\n\n/, $cmd_class->description; + $help .= join "\n\n" => @desc; + } + + my $opts = $options->docs('cli', groups => {':{' => '}:'}, category => $params{category}); + + my $usage = ''; + my $append = ''; + if (color()) { + $usage = join ' ' => ( + Term::ANSIColor::color('bold white') . "USAGE:" . Term::ANSIColor::color('reset'), + Term::ANSIColor::color('white') . $0, + Term::ANSIColor::color('cyan') . "[YATH OPTIONS]", + Term::ANSIColor::color('bold green') . $cmd . Term::ANSIColor::color('reset'), + Term::ANSIColor::color('cyan') . "[OPTIONS FOR COMMAND AND/OR YATH]", + Term::ANSIColor::color('yellow') . "[--]", + ); + + $append = $cmd_class->args_include_tests ? ' ' . join " " => ( + Term::ANSIColor::color('white') . "[ARGUMENTS/TESTS]", + Term::ANSIColor::color('green') . "[TEST :{ ARGS TO PASS TO TEST }:]", + Term::ANSIColor::color('magenta') . "[:: PASS-THROUGH]" . Term::ANSIColor::color('reset') + ) : Term::ANSIColor::color('white') . " [ARGUMENTS]"; + } + else { + $usage = "USAGE: $0 [YATH OPTIONS] $cmd [OPTIONS FOR COMMAND AND/OR YATH] [--]"; + $append = $cmd_class->args_include_tests ? " [ARGUMENTS/TESTS] [TEST :{ ARGS TO PASS TO TEST }:] [:: PASS-THROUGH]" : " [ARGUMENTS]"; + } + + + return "${usage}${append}\n${help}\n${opts}\n"; +} + +sub generate_run_sub { + my $self = shift; + my ($symbol) = @_; + + my $settings = $self->{+SETTINGS}; + + $self->process_args(); + + my $cmd_class = $self->command; + $settings->yath->create_option(command => $cmd_class) if $cmd_class; + + $self->handle_debug(); + + my $cmd = $cmd_class->new(settings => $settings, args => $self->argv, env_vars => $self->{+ENV_VARS}); + + return $cmd->generate_run_sub($symbol) if $cmd->can('generate_run_sub'); + + my $run = sub { $self->run_command($cmd) }; + + { + no strict 'refs'; + *{$symbol} = $run; + } + + return; +} + +sub run_command { + my $self = shift; + my ($cmd) = @_; + + my $exit = $cmd->run($self); + + die "Command '" . $cmd->name() . "' did not return an exit value.\n" + unless defined $exit; + + return $exit; +} + +sub include_options { + my $self = shift; + my ($type, $namespace) = @_; + + my $yath_s = $self->settings->yath; + + my $opt_scan = $yath_s->scan_options->{options} // 1; + my $type_scan = $yath_s->scan_options->{$type} // 1; + return unless $opt_scan || $type_scan; + + my $opts = $self->{+OPTIONS}; + + my $option_libs = find_libraries($namespace); + + for my $lib (sort keys %$option_libs) { + my $ok = eval { require $option_libs->{$lib}; 1 }; + unless ($ok) { + chomp($@); + warn "\n==== Failed to load module '$option_libs->{$lib}' ====\n$@\n==== End error for '$option_libs->{$lib}' ====\n\n"; + next; + } + + next unless $lib->can('options'); + my $add = $lib->options; + next unless $add; + + unless (blessed($add) && $add->isa('Getopt::Yath::Instance')) { + warn "Module '$option_libs->{$lib}' is outdated, not loading options.\n" + unless $ENV{'YATH_SELF_TEST'}; + next; + } + + $opts->include($add); + } +} + +sub options { + my $self = shift; + + return $self->{+OPTIONS} if $self->{+OPTIONS}; + + $self->{+OPTIONS} = Getopt::Yath::Instance->new( + category_sort_map => { + 'NO CATEGORY - FIX ME' => 99999, + 'Yath Options' => -100, + 'Command Options' => -90, + 'Harness Options' => -80, + }, + ); + $self->{+OPTIONS}->include(App::Yath::Options::Yath->options); + + warn "Verify plugin options are included"; + $self->include_options('plugins' => 'App::Yath::Plugin::*'); + $self->include_options('resource' => 'App::Yath::Resource::*'); + + return $self->{+OPTIONS}; +} + +sub process_args { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + + # First process the global yath args + my $yath_options = $self->options; + + my ($env, $cleared, $modules) = ({}, {}, {}); + my $state = $yath_options->process_args( + $self->argv, + + env => $env, + cleared => $cleared, + modules => $modules, + settings => $settings, + stops => ['--', '::'], + groups => {':{' => '}:'}, + + stop_at_non_opts => 1, + + invalid_opt_callback => sub { + my ($opt) = @_; + print STDERR "\nERROR: '$opt' is not a valid yath option.\n (Command specific options must come after the command, did you forget to specify a command?)\n\n" . $self->cli_help($yath_options); + exit 255; + }, + ); + + my ($cmd, $cmd_class); + if ($cmd = $state->{stop}) { + if ($cmd eq '--' || $cmd eq '::') { + print STDERR "\nERROR: '$cmd' must be used after the yath sub-command.\n\n" . $self->cli_help($yath_options); + exit 255; + } + + $cmd_class = "App::Yath::Command::$cmd"; + my $cmd_file = mod2file($cmd_class); + unless (eval { require $cmd_file; die "$cmd_class does not subclass App::Yath::Command.\n" unless $cmd_class->isa('App::Yath::Command'); 1 }) { + my $eq80 = '=' x 80; + print STDERR "\nERROR: '$cmd' ($cmd_class) does not look like a valid command:\n${eq80}\n$@${eq80}\n"; + exit 255; + } + + $yath_options->include($cmd_class->options) if $cmd_class->can('options'); + $settings->yath->create_option(command => $cmd_class); + $self->{+COMMAND} = $cmd_class; + + $state = $yath_options->process_args( + $state->{remains}, + + env => $env, + cleared => $cleared, + modules => $modules, + settings => $settings, + stops => ['--', '::'], + groups => {':{' => '}:'}, + + skip_non_opts => 1, + + invalid_opt_callback => sub { + my ($opt) = @_; + print STDERR "\nERROR: '$opt' is not a valid yath or '$cmd' command option.\n\n" . $self->cli_help($yath_options); + exit 255; + }, + ); + } + + $self->{argv} = [@{$state->{skipped}}, @{$state->{remains}}]; + $self->{+ENV_VARS} = $env; + + $self->clear_env; + + for my $module (keys %$modules) { + $settings->yath->{plugins}->{$module} //= [$module->can('args_from_settings') ? $module->args_from_settings($settings) : ()] if $module->isa('App::Yath::Plugin'); + $settings->renderer->{classes}->{$module} //= [$module->can('args_from_settings') ? $module->args_from_settings($settings) : ()] if $module->isa('App::Yath::Renderer'); + $settings->resource->{classes}->{$module} //= [$module->can('args_from_settings') ? $module->args_from_settings($settings) : ()] if $module->isa('App::Yath::Resource'); + warn "FIXME renderers and resources (if applicable)"; + } +} + +sub clear_env { + delete $ENV{HARNESS_IS_VERBOSE}; + delete $ENV{T2_FORMATTER}; + delete $ENV{T2_HARNESS_FORKED}; + delete $ENV{T2_HARNESS_IS_VERBOSE}; + delete $ENV{T2_HARNESS_JOB_IS_TRY}; + delete $ENV{T2_HARNESS_JOB_NAME}; + delete $ENV{T2_HARNESS_PRELOAD}; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_FILE}; + delete $ENV{T2_STREAM_JOB_ID}; + delete $ENV{TEST2_JOB_DIR}; + delete $ENV{TEST2_RUN_DIR}; + + # If Test2::API is already loaded then we need to keep these. + delete $ENV{TEST2_ACTIVE} unless $INC{'Test2/API.pm'}; + delete $ENV{TEST_ACTIVE} unless $INC{'Test2/API.pm'}; +} + +sub handle_debug { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + my $yath_options = $self->options; + + my $cmd_class = $self->{+COMMAND}; + my $cmd = $cmd_class ? $cmd_class->name : ''; + + my $show_help; + my $exit; + if ($settings->yath->version) { + $show_help = 0; + print $self->version_info() . "\n\n"; + $exit //= 0; + } + + if (!$cmd_class && !$settings->yath->help) { + $show_help //= 1; + $exit = 255; + } + + if ($settings->yath->help || $show_help) { + my $help = "\n"; + + if (!$cmd_class && !$settings->yath->help) { + $help .= "No command specified!\n\n"; + } + + my $cat = $settings->yath->help; + my %cli_params; + $cli_params{category} = $cat if $cat && $cat ne '1'; + $help .= $self->cli_help($yath_options, %cli_params); + + if (eval { require IO::Pager; 1 }) { + local $SIG{PIPE} = sub {}; + my $pager = IO::Pager->new(*STDOUT); + $pager->print($help); + } + else { + print $help; + } + + $exit //= 0; + } + + if (my $group = $settings->yath->show_opts) { + print "\nCommand selected: $cmd ($cmd_class)\n" if $cmd && $cmd_class; + + my @args = @{$self->argv}; + print "\nargs: " . join(', ' => @args) . "\n" if @args; + + my $out = $group eq '1' ? encode_pretty_json($settings) : encode_pretty_json($settings->{$group} // "!! Invalid Group '$group' !!"); + + print "\nCurrent command line and config options result in these settings:\n"; + print "$out\n"; + + $exit //= 0; + } + + exit($exit) if defined $exit; +} + +sub version_info { + my $self = shift; + + my $out = <<" EOT"; + +Yath version: $VERSION + +Extended Version Info + EOT + + my $plugin_libs = find_libraries('App::Yath::Plugin::*'); + + my @vers = ( + [perl => $^V], + ['App::Yath' => App::Yath->VERSION], + $self->command ? [$self->command, $self->command->VERSION // 'N/A'] : (), + ( + map { + eval { require(mod2file($_)); 1 } + ? [$_ => $_->VERSION // 'N/A'] + : [$_ => 'N/A'] + } qw/Test2::API Test2::Suite Test::Builder Test2::Harness Test2::Harness::UI/, + ), + ( + map { + eval { require($plugin_libs->{$_}); 1 } + && [$_ => $_->VERSION // 'N/A'] + } sort keys %$plugin_libs + ), + ); + + $out .= join "\n" => table( + header => [qw/COMPONENT VERSION/], + rows => \@vers, + ); + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath - Yet Another Test Harness (Test2-Harness) Command Line Interface +(CLI) + +=head1 DESCRIPTION + +This is the primary documentation for C<yath>, L<App::Yath>, L<Test2::Harness>. + +The canonical source of up-to-date command options are the help output when +using C<$ yath help> and C<$ yath help COMMAND>. + +This document is mainly an overview of C<yath> usage and common recipes. + +L<App::Yath> is an alternative to L<App::Prove>, and L<Test2::Harness> is an alternative to L<Test::Harness>. It is not designed to +replace L<Test::Harness>/prove. L<Test2::Harness> is designed to take full +advantage of the rich data L<Test2> can provide. L<Test2::Harness> is also able to +use non-core modules and provide more functionality than prove can achieve with +its restrictions. + +=head1 PLATFORM SUPPORT + +L<Test2::Harness>/L<App::Yath> is is focused on unix-like platforms. Most +development happens on linux, but bsd, macos, etc should work fine as well. + +Patches are welcome for any/all platforms, but the primary author (Chad +'Exodist' Granum) does not directly develop against non-unix platforms. + +=head2 WINDOWS + +Currently windows is not supported, and it is known that the package will not +install on windows. Patches are be welcome, and it would be great if someone +wanted to take on the windows-support role, but it is not a primary goal for +the project. + +=head1 OVERVIEW + +To use L<Test2::Harness>, you use the C<yath> command. Yath will find the tests +(or use the ones you specify) and run them. As it runs, it will output +diagnostic information such as failures. At the end, yath will print a summary +of the test run. + +C<yath> can be thought of as a more powerful alternative to C<prove> +(L<Test::Harness>) + +=head1 RECIPES + +These are common recipes for using C<yath>. + +=head2 RUN PROJECT TESTS + + $ yath + +Simply running yath with no arguments means "Run all tests for the current +project". Yath will look for tests in C<./t>, C<./t2>, and C<./test.pl> and +run any which are found. + +Normally this implies the C<test> command but will instead imply the C<run> +command if a persistent test runner is detected. + +=head2 PRELOAD MODULES + +Yath has the ability to preload modules. Yath normally forks to start new +tests, so preloading can reduce the time spent loading modules over and over in +each test. + +Note that some tests may depend on certain modules not being loaded. In these +cases you can add the C<# HARNESS-NO-PRELOAD> directive to the top of the test +files that cannot use preload. + +=head3 SIMPLE PRELOAD + +Any module can be preloaded: + + $ yath -PMoose + +You can preload as many modules as you want: + + $ yath -PList::Util -PScalar::Util + +=head3 COMPLEX PRELOAD + +If your preload is a subclass of L<Test2::Harness::Runner::Preload> then more +complex preload behavior is possible. See those docs for more info. + +=head2 LOGGING + +=head3 RECORDING A LOG + +You can turn on logging with a flag. The filename of the log will be printed at +the end. + + $ yath -L + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl + +The event log can be quite large. It can be compressed with bzip2. + + $ yath -B + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +gzip compression is also supported. + + $ yath -G + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.gz + +C<-B> and C<-G> both imply C<-L>. + +=head3 REPLAYING FROM A LOG + +You can replay a test run from a log file: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +This will be significantly faster than the initial run as no tests are actually +being executed. All events are simply read from the log, and processed by the +harness. + +You can change display options and limit rendering/processing to specific test +jobs from the run: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 -v [TEST UUID(S)] + +Note: This is done using the C<$ yath replay ...> command. The C<replay> +command is implied if the first argument is a log file. + +=head2 PER-TEST TIMING DATA + +The C<-T> option will cause each test file to report how long it took to run. + + $ yath -T + + ( PASSED ) job 1 t/yath_script.t + ( TIME ) job 1 Startup: 0.07692s | Events: 0.01170s | Cleanup: 0.00190s | Total: 0.09052s + +=head2 PERSISTENT RUNNER + +yath supports starting a yath session that waits for tests to run. This is very +useful when combined with preload. + +=head3 STARTING + +This starts the server. Many options available to the 'test' command will work +here but not all. See C<$ yath help start> for more info. + + $ yath start + +=head3 RUNNING + +This will run tests using the persistent runner. By default, it will search for +tests just like the 'test' command. Many options available to the C<test> +command will work for this as well. See C<$ yath help run> for more details. + + $ yath run + +=head3 STOPPING + +Stopping a persistent runner is easy. + + $ yath stop + +=head3 INFORMATIONAL + +The C<which> command will tell you which persistent runner will be used. Yath +searches for the persistent runner in the current directory, then searches in +parent directories until it either hits the root directory, or finds the +persistent runner tracking file. + + $ yath which + +The C<watch> command will tail the runner's log files. + + $ yath watch + +=head3 PRELOAD + PERSISTENT RUNNER + +You can use preloads with the C<yath start> command. In this case, yath will +track all the modules pulled in during preload. If any of them change, the +server will reload itself to bring in the changes. Further, modified modules +will be blacklisted so that they are not preloaded on subsequent reloads. This +behavior is useful if you are actively working on a module that is normally +preloaded. + +=head2 MAKING YOUR PROJECT ALWAYS USE YATH + + $ yath init + +The above command will create C<test.pl>. C<test.pl> is automatically run by +most build utils, in which case only the exit value matters. The generated +C<test.pl> will run C<yath> and execute all tests in the C<./t> and/or C<./t2> +directories. Tests in C<./t> will ALSO be run by prove but tests in C<./t2> +will only be run by yath. + +=head2 PROJECT-SPECIFIC YATH CONFIG + +You can write a C<.yath.rc> file. The file format is very simple. Create a +C<[COMMAND]> section to start the configuration for a command and then +provide any options normally allowed by it. When C<yath> is run inside your +project, it will use the config specified in the rc file, unless overridden +by command line options. + +B<Note:> You can also add pre-command options by placing them at the top of +your config file I<BEFORE> any C<[cmd]> markers. + +Comments start with a semi-colon. + +Example .yath.rc: + + -pFoo ; Load the 'foo' plugin before dealing with commands. + + [test] + -B ;Always write a bzip2-compressed log + + [start] + -PMoose ;Always preload Moose with a persistent runner + +This file is normally committed into the project's repo. + +=head3 SPECIAL PATH PSEUDO-FUNCTIONS + +Sometimes you want to specify files relative to the .yath.rc so that the config +option works from any subdirectory of the project. Other times you may wish to +use a shell expansion. Sometimes you want both! + +=over 4 + +=item rel(path/to/file) + + -I rel(path/to/extra_lib) + -I=rel(path/to/extra_lib) + +This will take the path to C<.yath.rc> and prefix it to the path inside +C<rel(...)>. If for example you have C</project/.yath.rc> then the path would +become C</project/path/to/extra_lib>. + +=item glob(path/*/file) + + --default-search glob(subprojects/*/t) + --default-search=glob(subprojects/*/t) + +This will add a C<--default-search $_> for every item found in the glob. This +uses the perl builtin function C<glob()> under the hood. + +=item relglob(path/*/file) + + --default-search relglob(subprojects/*/t) + --default-search=relglob(subprojects/*/t) + +Same as C<glob()> except paths are relative to the C<.yath.rc> file. + +=back + +=head2 PROJECT-SPECIFIC YATH CONFIG USER OVERRIDES + +You can add a C<.yath.user.rc> file. Format is the same as the regular +C<.yath.rc> file. This file will be read in addition to the regular config +file. Directives in this file will come AFTER the directives in the primary +config so it may be used to override config. + +This file should not normally be committed to the project repo. + +=head2 HARNESS DIRECTIVES INSIDE TESTS + +C<yath> will recognise a number of directive comments placed near the top of +test files. These directives should be placed after the C<#!> line but +before any real code. + +Real code is defined as any line that does not start with use, require, BEGIN, package, or # + +=over 4 + +=item good example 1 + + #!/usr/bin/perl + # HARNESS-NO-FORK + + ... + +=item good example 2 + + #!/usr/bin/perl + use strict; + use warnings; + + # HARNESS-NO-FORK + + ... + +=item bad example 1 + + #!/usr/bin/perl + + # blah + + # HARNESS-NO-FORK + + ... + +=item bad example 2 + + #!/usr/bin/perl + + print "hi\n"; + + # HARNESS-NO-FORK + + ... + +=back + +=head3 HARNESS-NO-PRELOAD + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + +Use this if your test will fail when modules are preloaded. This will tell yath +to start a new perl process to run the script instead of forking with preloaded +modules. + +Currently this implies HARNESS-NO-FORK, but that may not always be the case. + +=head3 HARNESS-NO-FORK + + #!/usr/bin/perl + # HARNESS-NO-FORK + +Use this if your test file cannot run in a forked process, but instead must be +run directly with a new perl process. + +This implies HARNESS-NO-PRELOAD. + +=head3 HARNESS-NO-STREAM + +C<yath> usually uses the L<Test2::Formatter::Stream> formatter instead of TAP. +Some tests depend on using a TAP formatter. This option will make C<yath> use +L<Test2::Formatter::TAP> or L<Test::Builder::Formatter>. + +=head3 HARNESS-NO-IO-EVENTS + +C<yath> can be configured to use the L<Test2::Plugin::IOEvents> plugin. This +plugin replaces STDERR and STDOUT in your test with tied handles that fire off +proper L<Test2::Event>'s when they are printed to. Most of the time this is not +an issue, but any fancy tests or modules which do anything with STDERR or +STDOUT other than print may have really messy errors. + +B<Note:> This plugin is disabled by default, so you only need this directive if +you enable it globally but need to turn it back off for select tests. + +=head3 HARNESS-NO-TIMEOUT + +C<yath> will usually kill a test if no events occur within a timeout (default +60 seconds). You can add this directive to tests that are expected to trip the +timeout, but should be allowed to continue. + +NOTE: you usually are doing the wrong thing if you need to set this. See: +C<HARNESS-TIMEOUT-EVENT>. + +=head3 HARNESS-TIMEOUT-EVENT 60 + +C<yath> can be told to alter the default event timeout from 60 seconds to another +value. This is the recommended alternative to HARNESS-NO-TIMEOUT + +=head3 HARNESS-TIMEOUT-POSTEXIT 15 + +C<yath> can be told to alter the default POSTEXIT timeout from 15 seconds to another value. + +Sometimes a test will fork producing output in the child while the parent is +allowed to exit. In these cases we cannot rely on the original process exit to +tell us when a test is complete. In cases where we have an exit, and partial +output (assertions with no final plan, or a plan that has not been completed) +we wait for a timeout period to see if any additional events come into + +=head3 HARNESS-DURATION-LONG + +This lets you tell C<yath> that the test file is long-running. This is +primarily used when concurrency is turned on in order to run longer tests +earlier, and concurrently with shorter ones. There is also a C<yath> option to +skip all long tests. + +This duration is set automatically if HARNESS-NO-TIMEOUT is set. + +=head3 HARNESS-DURATION-MEDIUM + +This lets you tell C<yath> that the test is medium. + +This is the default duration. + +=head3 HARNESS-DURATION-SHORT + +This lets you tell C<yath> That the test is short. + +=head3 HARNESS-CATEGORY-ISOLATION + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests. Yath will hold off and run these tests one at a time after all other +tests. + +=head3 HARNESS-CATEGORY-IMMISCIBLE + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests of this class. This is helpful when you have multiple tests which would +otherwise have to be run sequentially at the end of the run. + +Yath prioritizes running these tests above HARNESS-CATEGORY-LONG. + +=head3 HARNESS-CATEGORY-GENERAL + +This is the default category. + +=head3 HARNESS-CONFLICTS-XXX + +This lets you tell C<yath> that no other test of type XXX can be run at the +same time as this one. You are able to set multiple conflict types and C<yath> +will honor them. + +XXX can be replaced with any type of your choosing. + +NOTE: This directive does not alter the category of your test. You are free +to mark the test with LONG or MEDIUM in addition to this marker. + +=head3 HARNESS-JOB-SLOTS 2 + +=head3 HARNESS-JOB-SLOTS 1 10 + +Specify a range of job slots needed for the test to run. If set to a single +value then the test will only run if it can have the specified number of slots. +If given a range the test will require at least the lower number of slots, and +use up to the maximum number of slots. + +=over 4 + +=item Example with multiple lines. + + #!/usr/bin/perl + # DASH and space are split the same way. + # HARNESS-CONFLICTS-DAEMON + # HARNESS-CONFLICTS MYSQL + + ... + +=item Or on a single line. + + #!/usr/bin/perl + # HARNESS-CONFLICTS DAEMON MYSQL + + ... + +=back + +=head3 HARNESS-RETRY-n + +This lets you specify a number (minimum n=1) of retries on test failure +for a specific test. HARNESS-RETRY-1 means a failing test will be run twice +and is equivalent to HARNESS-RETRY. + +=head3 HARNESS-NO-RETRY + +Use this to avoid this test being retried regardless of your retry settings. + +=head1 MODULE DOCS + +This section documents the L<App::Yath> module itself. + +=head2 SYNOPSIS + +In practice you should never need to write your own yath script, or construct +an L<App::Yath> instance, or even access themain instance when yath is running. +However some aspects of doing so are documented here for completeness. + +A minimum yath script looks like this: + + BEGIN { + package App::Yath:Script; + + require Time::HiRes; + require App::Yath; + require App::Yath::Settings; + + my $settings = App::Yath::Settings->new( + harness => { + orig_argv => [@ARGV], + orig_inc => [@INC], + script => __FILE__, + start => Time::HiRes::time(), + version => $App::Yath::VERSION, + }, + ); + + my $app = App::Yath->new( + argv => \@ARGV, + config => {}, + settings => $settings, + ); + + $app->generate_run_sub('App::Yath::Script::run'); + } + + exit(App::Yath::Script::run()); + +It is important that most logic live in a BEGIN block. This is so that +L<goto::file> can be used post-fork to execute a test script. + +The actual yath script is significantly more complicated with the following behaviors: + +=over 4 + +=item pre-process essential arguments such as -D and no-scan-plugins + +=item re-exec with a different yath script if in developer mode and a local copy is found + +=item Parse the yath-rc config files + +=item gather and store essential startup information + +=back + +=head2 METHODS + +App::Yath does not provide many methods to use externally. + +=over 4 + +=item $app->generate_run_sub($symbol_name) + +This tells App::Yath to generate a subroutine at the specified symbol name +which can be run and be expected to return an exit value. + +=item $lib_path = $app->app_path() + +Get the include directory App::Yath was loaded from. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Command.pm b/lib2.0/App/Yath/Command.pm new file mode 100644 index 000000000..c7353ded7 --- /dev/null +++ b/lib2.0/App/Yath/Command.pm @@ -0,0 +1,191 @@ +package App::Yath::Command; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use File::Spec; +use Carp qw/croak/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::HashBase qw/<settings <args <env_vars/; + +use Test2::Harness::Util::File::JSON(); + +sub args_include_tests { 0 } +sub internal_only { 0 } +sub summary { "No Summary" } +sub description { "No Description" } +sub group { "Z-FIXME" } + +sub name { $_[0] =~ m/([^:=]+)(?:=.*)?$/; $1 || $_[0] } + +sub run { + my $self = shift; + + warn "This command is currently empty.\n"; + + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Command - Base class for yath commands + +=head1 DESCRIPTION + +This is the base class for any/all yath commands. If you wish to add a new yath +command you should subclass this package. + +=head1 SYNOPSIS + + package App::Yath::Command::mycommand; + use strict; + use warnings; + + use Getopt::Yath; + use parent 'App::Yath::Command'; + + # Include existing option sets + include_options( + 'App::Yath::Options::...', + ..., + ); + + # Add some custom options + option_group {group => 'mycommand', category => 'mycommand options'} => sub { + option foo => ( + type => 'Bool, + description => "the foo option", + default => 0, + ); + }; + + # This is used to sort/group commands in the "yath help" output + sub group { 'mycommand' } + + # Brief 1-line summary + sub summary { "This is a third party command, it does stuff..." } + + # Longer description of the command (used in yath help mycommand) + sub description { + return <<" EOT"; + This command does: + This + That + Those + EOT + } + + # Entrypoint + sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + print "Hello Third Party!\n" + + # Return an exit value. + return 0; + } + + 1; + +=head1 CLASS METHODS + +=over 4 + +=item $multi_line_string = $cmd_class->description() + +Long-form description of the command. Used in C<cli_help()>. + +=item $string = $cmd_class->group() + +Used for sorting/grouping commands in the C<yath help> output. + +Existing groups: + + ' test' # Space in front to make sure test related command float up + 'log' # Log processing commands + 'persist' # Commands related to the persistent runner + 'zinit' # The init command and related command sink to the bottom. + +Unless your command OBVIOUSLY and CLEARLY belongs in one of the above groups +you should probably create your own. Please do not prefix it with a space to +make it float, C<' test'> is a special case, you are not that special. + +=item $string = $cmd_class->name() + +Name of the command. By default this is the last part of the package name. You +will probably never want to override this. + +=item $short_string = $cmd_class->summary() + +A short summary of what this command is. + +=back + +=head1 OBJECT METHODS + +=over 4 + +=item $arrayref = $cmd->args() + +Get an arrayref of command line arguments B<AFTER> options have been +process/removed. + +=item $bool = $cmd->internal_only() + +Set this to true if you do not want your command to show up in the help output. + +=item $exit_code = $cmd->run() + +This is the main entrypoint for the command. You B<MUST> override this. This +method should return an exit code. + +=item $settings = $cmd->settings() + +Get the settings as populated by the command line options. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Command/foo.pm b/lib2.0/App/Yath/Command/foo.pm new file mode 100644 index 000000000..1b2fb8563 --- /dev/null +++ b/lib2.0/App/Yath/Command/foo.pm @@ -0,0 +1,66 @@ +package App::Yath::Command::foo; +use strict; +use warnings; + +use Test2::Harness::Util::JSON qw/decode_json/; + +use List::Util qw/mesh/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub name { 'foo' } + +sub description { "Hi There!" } + +use Getopt::Yath; + +option_group {category => 'Foo Options', group => 'foo'} => sub { + option foo => ( type => 'List', short => 'f' ); + option bar => ( type => 'Map' ); + option baz => ( type => 'Bool' ); + + option fields => ( + name => 'field', + type => 'List', + long_examples => [' name=details', qq[ '{"name":"NAME","details":"DETAILS"]], + short_examples => [' name=details', qq[ '{"name":"NAME","details":"DETAILS"]], + description => "Add custom data to the harness run", + normalize => sub { m/^\s*\{.*\}\s*$/s ? decode_json($_[0]) : {mesh(['name','details'], [split /[=]/, $_[0]])} }, + ); + + option env_vars => ( + type => 'Map', + alt => ['env_var'], + short => 'E', + alt_no => ['X'], + + description => 'Set environment variables to set when each test is run.', + ); + + option load_import => ( + type => 'Map', + short => 'M', + alt => ['loadim'], + + long_examples => [' Module', ' Module=import_arg1,arg2,...'], + short_examples => [' Module', ' Module=import_arg1,arg2,...'], + + description => 'Load a module in each test (after fork). Import is called.', + normalize => sub { $_[0] => [split /,/, $_[1]] }, + ); + +}; + +sub run { + my $self = shift; + my $args = $self->{+ARGS}; + + use Data::Dumper; + print Dumper($args); + + 0; +} + + +1; diff --git a/lib2.0/App/Yath/Command/help.pm b/lib2.0/App/Yath/Command/help.pm new file mode 100644 index 000000000..d87caff9f --- /dev/null +++ b/lib2.0/App/Yath/Command/help.pm @@ -0,0 +1,98 @@ +package App::Yath::Command::help; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/<_command_info_hash/; + +use Test2::Harness::Util qw/open_file find_libraries mod2file/; +use List::Util (); + +sub options {}; +sub group { '' } +sub summary { 'Show the list of commands' } + +sub description { + return <<" EOT" +This command provides a list of commands when called with no arguments. +When given a command name as an argument it will print the help for that +command. + EOT +} + +sub command_info_hash { + my $self = shift; + + return $self->{+_COMMAND_INFO_HASH} if $self->{+_COMMAND_INFO_HASH}; + + my %commands; + my $command_libs = find_libraries('App::Yath::Command::*'); + for my $lib (sort keys %$command_libs) { + my $ok = eval { require $command_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load command '$command_libs->{$lib}': $@"; + next; + } + + next if $lib->internal_only; + my $name = $lib->name; + my $group = $lib->group; + $commands{$group}->{$name} = $lib->summary; + } + + return $self->{+_COMMAND_INFO_HASH} = \%commands; +} + +sub command_list { + my $self = shift; + + my $command_hash = $self->command_info_hash(); + my @commands = map keys %$_, values %$command_hash; + return @commands; +} + +sub run { + my $self = shift; + my $args = $self->{+ARGS}; + + return $self->command_help($args->[0]) if @$args; + + my $script = $self->settings->yath->script // $0; + my $maxlen = List::Util::max(map length, $self->command_list); + + print "\nUsage: $script COMMAND [options]\n\nAvailable Commands:\n"; + + my $command_info_hash = $self->command_info_hash; + for my $group (sort keys %$command_info_hash) { + my $set = $command_info_hash->{$group}; + + printf(" %${maxlen}s: %s\n", $_, $set->{$_}) for sort keys %$set; + print "\n"; + } + + return 0; +} + +sub command_help { + my $self = shift; + my ($command) = @_; + + require App::Yath; + my $cmd_class = "App::Yath::Command::$command"; + require(mod2file($cmd_class)); + + my $app = App::Yath->new(command => $cmd_class, settings => $self->settings); + $app->options->include($cmd_class->options); + print $app->cli_help(); + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib2.0/App/Yath/Command/run.pm b/lib2.0/App/Yath/Command/run.pm new file mode 100644 index 000000000..579704775 --- /dev/null +++ b/lib2.0/App/Yath/Command/run.pm @@ -0,0 +1,11 @@ + +# Initialized options for 'Options::Tests' from the IPC shared state, that way --no-includes can clean includes from the runner, etc. + + warn "Implement skip queue"; + option skip_queue => ( + type => 'Bool', + + default => 0, + description => "Normally runs (groups of tests) will run 1 after another first-in first-out. This option will cause the runner to launch the run immedietly regardless of what else may be running.", + ); + diff --git a/lib2.0/App/Yath/Command/runner.pm b/lib2.0/App/Yath/Command/runner.pm new file mode 100644 index 000000000..f7188ea21 --- /dev/null +++ b/lib2.0/App/Yath/Command/runner.pm @@ -0,0 +1,632 @@ +package App::Yath::Command::runner; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use goto::file(); + +use Carp qw/confess/; +use Config qw/%Config/; + +use Scope::Guard; + +use Long::Jump qw/setjump longjump/; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Harness; + +my @SIGNALS = grep { $_ ne 'ZERO' } split /\s+/, $Config{sig_name}; + +# If FindBin is installed, go ahead and load it. We do not care much about +# success vs failure here. +BEGIN { + local $@; + eval { require FindBin; FindBin->import }; +} + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/<harness <runner_pid/; + +sub group { 'internal' } +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'runner' } + +sub run { confess(ref($_[0]) . " does not implement run()") } + +sub description { + return <<" EOT" +This command launches a runner. + EOT +} + +our $RUNNER_PID; + +sub init { + my $self = shift; + + $self->SUPER::init(@_) if App::Yath::Command->can('init'); + + $RUNNER_PID = $$; + $self->{+RUNNER_PID} = $$; + + my ($state_file) = @{$self->args}; + + confess "Did not get passed a state file" unless $state_file; + + my $inst = App::Yath::Harness->connect($state_file); + + $self->{+HARNESS} = $inst; + + $self->{+SETTINGS} = $inst->settings; + + return $self; +} + +sub generate_run_sub { + my $self = shift; + my ($symbol) = @_; + + my $settings = $self->settings; + my $name = $ENV{NESTED_YATH} ? 'yath-nested-runner' : 'yath-runner'; + $name = $settings->harness->procname_prefix . "-${name}" if $settings->harness->procname_prefix; + $0 = $name; + + my $jump = setjump "Test-Runner" => sub { + local $.; + + my %orig_sig = %SIG; + my $guard = Scope::Guard->new(sub { + my %seen; + for my $sig (@SIGNALS) { + next if $seen{$sig}++; + if (exists $orig_sig{$sig}) { + $SIG{$sig} = $orig_sig{$sig}; + } + else { + delete $SIG{$sig}; + } + } + }); + + my $runner = $self->harness->shared_get('runner', 'base'); + my $exit = $runner->start(); + + exit($exit // 1); + }; + + die "Test runner completed, but failed to exit" unless $jump; + + my ($action, $job, $stage) = @$jump; + + if($action eq 'respawn') { + print "$$ Respawning the runner...\n"; + exec(@{$self->harness->runner_cli}); + warn "exec failed!"; + exit 1; + } + + die "Invalid action: $action" if $action ne 'run_test'; + + if (my $chdir = $job->ch_dir) { + chdir($chdir) or die "Could not chdir: $!"; + } + goto::file->import($job->run_file); + warn "FIXME"; +# $class->cleanup_process($job, $stage); + DB::enable_profile() if $settings->runner->nytprof; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + +=cut + +package App::Yath::Command::runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Config qw/%Config/; +use File::Spec; + +# For some reason Filter::Util::Class breaks the STDIN filehandle. This works +# around that. +my $FIX_STDIN; +BEGIN { + require goto::file; + no strict 'refs'; + no warnings 'redefine'; + + my $int_done; + my $orig = goto::file->can('filter'); + *goto::file::filter = sub { + local $.; + my $out = $orig->(@_); + seek(STDIN, 0, 0) if $FIX_STDIN; + + unless ($int_done++) { + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + my $ok; + for (1 .. 10) { + $ok = open(STDIN, '<', $fifo); + last if $ok; + die "Could not open fifo ($fifo): $!"; + sleep 1; + } + + die "Could not open fifo ($fifo): $!" unless $ok; + + print STDERR <<' EOT'; + +******************************************************************************* +* YATH IS RUNNING IN INTERACTIVE MODE * +* * +* STDIN is comming from a fifo pipe, not a TTY! * +* * +* The $ENV{YATH_INTERACTIVE} var is set to the FIFO being used. * +* * +* VERBOSE mode has been turned on for you * +* * +* Only 1 test will run at a time * +* * +* The main yath process no longer has STDIN, so yath plugins that wait for * +* input WILL BREAK. * +* * +* Prompts that do not end with a newline may have a 1 second delay before * +* they are displayed, they will be prefixed with [INTERACTIVE] * +* * +* Any stdin/stdout that is printed in 2 parts without a newline and more than * +* a 1 second delay will be printed with the [INTERACTIVE] prefix, if they are * +* not actually a prompt you can safely ignore them. * +* * +* It is possible that a prompt was displayed before this message, please * +* check above if your prompt appears missing. This is an IO fluke, not a bug. * +* * +******************************************************************************* + + EOT + } + } + + return $out; + }; +} + +use Test2::Harness::IPC(); +use Test2::Harness::State; + +use Carp qw/confess/; +use Scalar::Util qw/openhandle/; +use List::Util qw/first/; +use File::Path qw/remove_tree/; + + +use Test2::Util qw/clone_io/; + +use Long::Jump qw/setjump longjump/; + +use Test2::Harness::Util qw/mod2file write_file_atomic open_file clean_path process_includes/; + +use Test2::Harness::Util::IPC qw/swap_io/; + +use Test2::Harness::Runner::Preloader(); + +my @SIGNALS = grep { $_ ne 'ZERO' } split /\s+/, $Config{sig_name}; + +# If FindBin is installed, go ahead and load it. We do not care much about +# success vs failure here. +BEGIN { + local $@; + eval { require FindBin; FindBin->import }; +} + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'runner' } + +sub init { confess(ref($_[0]) . " is not intended to be instantiated") } +sub run { confess(ref($_[0]) . " does not implement run()") } + +our $RUNNER_PID; +sub generate_run_sub { + my $class = shift; + my ($symbol, $argv, $spawn_settings) = @_; + my ($dir, %args) = @$argv; + + $RUNNER_PID = $$; + my $runner_pid = $$; + my $all_state = Test2::Harness::State->new(workdir => $dir); + my $settings = $all_state->settings; + + my $name = $ENV{NESTED_YATH} ? 'yath-nested-runner' : 'yath-runner'; + $name = $settings->debug->procname_prefix . "-${name}" if $settings->debug->procname_prefix; + $0 = $name; + + my $cleanup = $class->cleanup($settings, \%args, $dir); + + my $jump = setjump "Test-Runner" => sub { + local $.; + + my %orig_sig = %SIG; + my $guard = Scope::Guard->new(sub { + my %seen; + for my $sig (@SIGNALS) { + next if $seen{$sig}++; + if (exists $orig_sig{$sig}) { + $SIG{$sig} = $orig_sig{$sig}; + } + else { + delete $SIG{$sig}; + } + } + }); + + my $runner = $settings->build( + runner => 'Test2::Harness::Runner', + + %args, + + dir => $dir, + settings => $settings, + all_state => $all_state, + + fork_job_callback => sub { $class->launch_via_fork(@_) }, + fork_spawn_callback => sub { $class->launch_spawn(@_) }, + respawn_runner_callback => sub { return unless $$ == $runner_pid; longjump "Test-Runner" => 'respawn' }, + ); + + my $exit = $runner->process(); + + if ($$ == $runner_pid) { + $_->cleanup() for @{$runner->state->resources}; + } + + my $complete = File::Spec->catfile($dir, 'complete'); + write_file_atomic($complete, '1'); + + exit($exit // 1); + }; + + die "Test runner completed, but failed to exit" unless $jump; + + my ($action, $job, $stage) = @$jump; + + if($action eq 'respawn') { + print "$$ Respawning the runner...\n"; + $cleanup->dismiss(1); + exec($^X, $settings->harness->script, @{$spawn_settings->harness->orig_argv}); + warn "exec failed!"; + exit 1; + } + + die "Invalid action: $action" if $action ne 'run_test'; + + if (my $chdir = $job->ch_dir) { + chdir($chdir) or die "Could not chdir: $!"; + } + goto::file->import($job->run_file); + $class->cleanup_process($job, $stage); + DB::enable_profile() if $settings->runner->nytprof; +} + +sub get_stage { + my $class = shift; + my ($runner) = @_; + + return unless $runner->can('stage'); + + my $stage_name = $runner->stage or return; + my $preloader = $runner->preloader or return; + my $p = $preloader->staged or return; + + return $p->stage_lookup->{$stage_name}; +} + +sub launch_spawn { + my $class = shift; + my ($runner, $spawn) = @_; + + my $pid = fork() // die $!; + if ($pid) { + waitpid($pid, 0); + return; + } + + require POSIX; + POSIX::setsid or die "setsid: $!"; + + $pid = fork // die $!; + exit 0 if $pid; + + eval { + my ($wh); + pipe(STDIN, $wh) or die "Could not create pipe: $!"; + $pid = $class->launch_via_fork($runner, $spawn); + + if ($pid) { + open(my $fh, '>>', $spawn->{task}->{ipcfile}) or die "Could not open pidfile: $!"; + print $fh "$$\n$pid\n" . fileno($wh) . "\n"; + $fh->flush(); + waitpid($pid, 0); + print $fh "$?\n"; + close($fh); + } + + exit(0); + }; + warn "Unknown problem daemonizing: $@"; + exit(1); +} + +sub launch_via_fork { + my $class = shift; + my ($runner, $job) = @_; + + my $stage = $class->get_stage($runner); + + $stage->do_pre_fork($job) if $stage; + + my $pid = fork(); + die "Failed to fork: $!" unless defined $pid; + + # In parent + return $pid if $pid; + + # In Child + my $ok = eval { + $0 = 'yath-pending-test'; + setpgrp(0, 0) if Test2::Harness::IPC::USE_P_GROUPS(); + $runner->stop(); + + $stage->do_post_fork($job) if $stage; + + longjump "Test-Runner" => ('run_test', $job, $stage); + + 1; + }; + my $err = $@; + eval { warn $err } unless $ok; + exit(1); +} + +sub cleanup_process { + my $class = shift; + my ($job, $stage) = @_; + + $class->update_io($job); # Get the correct filehandles in place early + $class->set_env($job); # Set up the necessary env vars + $class->build_init_state($job); # Lots of 'misc' stuff. + $class->do_loads($job); # Modules that we wanted loaded/imported post fork + $class->test2_state($job); # Normalize the Test2 state + + $stage->do_pre_launch($job) if $stage; + + $class->final_state($job); # Important final cleanup +} + +sub test2_state { + my $class = shift; + my ($job) = @_; + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stop_preload(); + Test2::API::test2_post_preload_reset(); + } + + if ($job->use_stream) { + $ENV{T2_FORMATTER} = 'Stream'; + require Test2::Formatter::Stream; + Test2::Formatter::Stream->import(dir => $job->event_dir, job_id => $job->job_id); + } + + if ($job->event_uuids) { + require Test2::Plugin::UUID; + Test2::Plugin::UUID->import(); + } + + if ($job->mem_usage) { + require Test2::Plugin::MemUsage; + Test2::Plugin::MemUsage->import(); + } + + if ($job->io_events) { + require Test2::Plugin::IOEvents; + Test2::Plugin::IOEvents->import(); + } + + return; +} + +sub final_state { + my $class = shift; + my ($job) = @_; + + @ARGV = $job->args; + + # toggle -w switch late + $^W = 1 if $job->use_w_switch; + + # reset the state of empty pattern matches, so that they have the same + # behavior as running in a clean process. + # see "The empty pattern //" in perlop. + # note that this has to be dynamically scoped and can't go to other subs + "" =~ /^/; + + return; +} + +sub do_loads { + my $class = shift; + my ($job) = @_; + + local $@; + my $importer = eval <<' EOT' or die $@; +package main; +#line 0 "-" +sub { $_[0]->import(@{$_[1]}) } + EOT + + for my $set ($job->load_import) { + my ($mod, $args) = @$set; + my $file = mod2file($mod); + local $0 = '-'; + require $file; + $importer->($mod, $args); + } + + for my $mod ($job->load) { + my $file = mod2file($mod); + local $0 = '-'; + require $file; + } + + return; +} + +sub build_init_state { + my $class = shift; + my ($job) = @_; + + $0 = $job->rel_file; + $class->_reset_DATA(); + @ARGV = (); + + srand(); # avoid child processes sharing the same seed value as the parent + + @INC = process_includes( + list => [$job->includes], + include_dot => $job->unsafe_inc, + include_current => 1, + clean => 1, + ); + + # if FindBin is preloaded, reset it with the new $0 + FindBin::init() if defined &FindBin::init; + + # restore defaults + Getopt::Long::ConfigDefaults() if defined &Getopt::Long::ConfigDefaults; + + return; +} + +sub set_env { + my $class = shift; + my ($job) = @_; + + my $env = $job->env_vars; + { + no warnings 'uninitialized'; + $ENV{$_} = $env->{$_} for keys %$env; + } + + $ENV{T2_HARNESS_FORKED} = 1; + $ENV{T2_HARNESS_PRELOAD} = 1; + + return; +} + +sub update_io { + my $class = shift; + my ($job) = @_; + + my $out_fh = open_file($job->out_file, '>'); + my $err_fh = open_file($job->err_file, '>'); + + my $in_file = $job->in_file; + my $in_fh = open_file($in_file, '<') if $in_file; + + $out_fh->autoflush(1); + $err_fh->autoflush(1); + + # Keep a copy of the old STDERR for a while so we can still report errors + my $stderr = clone_io(\*STDERR); + + my $die = sub { + my @caller = caller; + my @caller2 = caller(1); + my $msg = "$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2]).\n"; + print $stderr $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $in_fh, $die, '<&') if $in_file; + swap_io(\*STDOUT, $out_fh, $die, '>&'); + swap_io(\*STDERR, $err_fh, $die, '>&'); + + $FIX_STDIN = 1 if $in_file; + + return; +} + +# Heavily modified from forkprove +sub _reset_DATA { + my $class = shift; + + for my $set (@{$class->preload_list}) { + my ($mod, $file, $pos) = @$set; + + my $fh = do { + no strict 'refs'; + *{$mod . '::DATA'}; + }; + + # note that we need to ensure that each forked copy is using a + # different file handle, or else concurrent processes will interfere + # with each other + + close $fh if openhandle($fh); + + if (open $fh, '<', $file) { + seek($fh, $pos, 0); + } + else { + warn "Couldn't reopen DATA for $mod ($file): $!"; + } + } +} + +# Heavily modified from forkprove +sub preload_list { + my $class = shift; + + my $list = []; + + for my $loaded (keys %INC) { + next unless $loaded =~ /\.pm$/; + + my $mod = $loaded; + $mod =~ s{/}{::}g; + $mod =~ s{\.pm$}{}; + + my $fh = do { + no strict 'refs'; + no warnings 'once'; + *{$mod . '::DATA'}; + }; + + next unless openhandle($fh); + push @$list => [$mod, $INC{$loaded}, tell($fh)]; + } + + return $list; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib2.0/App/Yath/Command/test.pm b/lib2.0/App/Yath/Command/test.pm new file mode 100644 index 000000000..40bddbb4a --- /dev/null +++ b/lib2.0/App/Yath/Command/test.pm @@ -0,0 +1,1112 @@ +package App::Yath::Command::test; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Time::HiRes qw/sleep/; + +use Test2::Harness::Collector::IOParser; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util qw/mod2file clean_path/; +use Test2::Harness::Run; + +use App::Yath::Harness; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/ + +harness + +scheduler +/; + +use Getopt::Yath; +include_options( + 'App::Yath::Options::Finder', + 'App::Yath::Options::Harness', + 'App::Yath::Options::Renderer', + 'App::Yath::Options::Resource', + 'App::Yath::Options::Run', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Scheduler', + 'App::Yath::Options::Tests', + 'App::Yath::Options::Yath', +); + +# TODO: Might make sense to move this to the 'run' command and just include it here. +option_group {group => 'command', category => 'Command Options'} => sub { + warn "Fix interactive mode"; + option interactive => ( + type => 'Bool', + short => 'i', + + description => 'Use interactive mode, 1 test at a time, stdin forwarded to it', + set_env_vars => ['YATH_INTERACTIVE'], + from_env_vars => ['YATH_INTERACTIVE'], + ); + + option preload_threshold => ( + type => 'Scalar', + short => 'W', + alt => ['Pt'], + default => 0, + + description => "Only do preload if at least N tests are going to be run. In some cases a full preload takes longer than simply running the tests, this lets you specify a minimum number of test jobs that will be run for preload to happen. The default is 0, and it means always preload." + ); +}; + +sub args_include_tests { 1 } + +sub group { ' test' } + +sub summary { "Run tests" } + +sub description { + return <<" EOT"; +This yath command will run all the test files for the current project. If no test files are specified this command will look for the 't', and 't2' directories, as well as the 'test.pl' file. + +This command is always recursive when given directories. + +This command will add 'lib', 'blib/arch' and 'blib/lib' to the perl path for you by default (after any -I's). You can specify -l if you just want lib, -b if you just want the blib paths. If you specify both -l and -b both will be added in the order you specify (order relative to any -I options will also be preserved. If you do not specify they will be added in this order: -I's, lib, blib/lib, blib/arch. You can also add --no-lib and --no-blib to avoid both. + +Any command line argument that is not an option will be treated as a test file or directory of test files to be run. + +If you wish to specify the ARGV for tests you may append them after '::'. This is mainly useful for Test::Class::Moose and similar tools. EVERY test executed will get the same ARGV. + EOT +} + +sub harness { + my $self = shift; + return $self->{+HARNESS} if $self->{+HARNESS}; + + my $settings = $self->settings; + my $workdir = $settings->harness->workdir; + my $tmpdir = File::Spec->catdir($workdir, 'tmp'); + my $statefile = File::Spec->catfile($workdir, 'test_state.json'); + + mkdir($tmpdir) unless -d $tmpdir; + + $self->{+HARNESS} = App::Yath::Harness->create( + $statefile, + workdir => $workdir, + tmpdir => $tmpdir, + + dummy => $settings->harness->dummy, + procname_prefix => $settings->harness->procname_prefix, + keep_dirs => $settings->harness->keep_dirs, + + project => $settings->yath->project, + + settings => $settings, + ); +} + +sub run { + my $self = shift; + my ($app) = @_; + + my $settings = $self->settings; + my $inst = $self->harness; + + warn "Fix this"; + $0 = "yath"; + + warn "init plugins plz..."; + my $plugins = []; + + my $run_id = $settings->run->run_id; + my $run = $inst->shared_init(run => $run_id, $settings->run->all); + my $scheduler = $inst->shared_init(scheduler => $settings->scheduler->all); + my $base_runner = $inst->shared_init(runner => 'base', $settings->runner->all); + + # Get list of tests to run + my $finder_class = $settings->finder->class; + require(mod2file($finder_class)); + my $finder = $finder_class->new($settings->finder->all, settings => $settings, search => $self->{+ARGS}, run_id => $run_id, state => $inst); + $finder->find_files($plugins); + + $scheduler->queue($run_id); + $scheduler->terminate_queue(); + + my $runner_agg = $inst->shared_init(aggregator => 'runner', name => 'runner'); + my $run_agg = $inst->shared_init(aggregator => $run_id, name => $run_id); + + $runner_agg->spawn(); + $run_agg->spawn(); + + my $have_renderer = $self->init_many( + 'renderer', + spawn_args => {aggregators => {runner => 'runner', run => $run_id}}, + inst_args => { + $settings->renderer->all, + interactive => $settings->command->interactive, + is_persistent => 0, + }, + ); + + my $have_job_limiter = $self->init_many('resource', count => 'is_job_limiter', collector => 'runner'); + my $limiter = $inst->shared_init('resource' => 'job_limiter', job_count => 1, slots_per_job => 1, class => 'App::Yath::Resource::Jobs'); + + $base_runner->spawn_collected( + collector => { + output => $runner_agg->writer, + parser => Test2::Harness::Collector::IOParser->new(type => 'runner', name => 'runner', tag => 'runner'), + }, + run_method => sub { + my @libs = @INC; + unshift @libs => @{$settings->tests->includes // []}; + unshift @libs => @{$settings->yath->dev_libs // []}; + + my %seen; + @libs = map { "-I$_" } grep { !$seen{$_}++ } map { clean_path($_) } @libs; + + my @cli = ($^X, @libs, $settings->yath->script, 'runner', $inst->state_file); + + $inst->transaction(w => sub { $inst->set_runner_cli(\@cli) }); + + exec(@cli); + }, + ); + + $scheduler->spawn_collected( + collector => { + output => $runner_agg->writer, + parser => Test2::Harness::Collector::IOParser->new(type => 'scheduler', name => 'scheduler', tag => 'schedule'), + }, + ); + + return $inst->become_primary_proc_manager( + callback => sub { + local $SIG{CHLD} = sub { print "Child Exited\n" }; + while (1) { + my @pids = map { $_->is_my_child } $base_runner, $scheduler; + $inst->wait_all(subset => \@pids); + + #next if $scheduler->is_running; + #next if $base_runner->is_running; + last; + } + + $inst->finalize(); + $inst->wait_all(); + }, + ); +} + +sub init_many { + my $self = shift; + my ($type, %params) = @_; + + my $collector = delete $params{collector}; + my $count_meth = $params{count}; + my $count = 0; + + my $settings = $self->settings; + my $inst = $self->harness; + + my $agg; + + my $classes = $settings->$type->classes; + for my $class (sort keys %$classes) { + my %args = ( + %{$params{inst_args} // {}}, + @{$classes->{$class} // []}, + class => $class, + ); + + delete $args{classes}; + + my $obj = $inst->shared_init($type => $class, %args); + + $count++ if !$count_meth || $obj->$count_meth; + + next unless $obj->can('run'); + + if ($collector) { + $agg //= $self->harness->shared_get(aggregator => $collector); + $obj->spawn_collected( + %{$params{spawn_args} // {}}, + collector => { + output => $agg->writer, + parser => Test2::Harness::Collector::IOParser->new(type => $type, name => $class, tag => $class->tag), + }, + ); + } + else { + $obj->spawn(%{$params{spawn_args} // {}}); + } + + } + + return $count; +} + +#$self->_gen_test_data($run_id, $runner_agg, $run_agg); +warn "Remove this cruft"; +sub _gen_test_data { + my $self = shift; + my ($run_id, $agg1, $agg2) = @_; + + my $inst = $self->harness; + my $w1 = $agg1->writer; + my $w2 = $agg2->writer; + + my $pid = fork // die "Could not fork: $!"; + use Test2::Harness::Util::JSON qw/encode_json/; + + if ($pid) { + waitpid($pid, 0); + return; + } + else { + for (1 .. 10) { + $w1->write_message(encode_json({facet_data => {info => [{ details => "root: $_", tag => 'foo'}]}, count => $_, id => 'root'})); + $w2->write_message(encode_json({facet_data => {info => [{ details => "$run_id: $_", tag => 'foo'}]}, count => $_, id => $run_id})); + } + + exit 0; + } +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + +=cut + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + my $plugins = $settings->harness->plugins; + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my @add_to_queue; + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + $state->queue_task($task); + + push @add_to_queue => $task; + } + + + + +sub state { + my $self = shift; + + return $self->{+STATE} if $self->{+STATE}; + + my $settings = $self->settings; + + my $state = Test2::Harness::State->new( + settings => $settings, + workdir => $settings->workspace->workdir, + job_count => $settings->runner->job_count, + access_id => 'test command', + access_pid => $$, + timeout => 0, + ); + + $state->transaction('w'); + + return $self->{+STATE} = $state; +} + +sub workdir { shift->state->workdir } +sub job_count { shift->state->job_count } + +sub spawn_args { + my $self = shift; + my ($settings) = @_; + + my @out; + + if ($ENV{T2_DEVEL_COVER} && $ENV{T2_COVER_SELF}) { + push @out => '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + } + + my $plugins = $self->state->plugins('spawn_args'); + push @out => $_->spawn_args($settings) for @$plugins; + + return @out; +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; + + $self->{+CLEANUP_SUBS} = []; +} + +sub auditor_reader { + my $self = shift; + return $self->{+AUDITOR_READER} if $self->{+AUDITOR_READER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+AUDITOR_READER}; +} + +sub collector_writer { + my $self = shift; + return $self->{+COLLECTOR_WRITER} if $self->{+COLLECTOR_WRITER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+COLLECTOR_WRITER}; +} + +sub renderer_reader { + my $self = shift; + return $self->{+RENDERER_READER} if $self->{+RENDERER_READER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+RENDERER_READER}; +} + +sub auditor_writer { + my $self = shift; + return $self->{+AUDITOR_WRITER} if $self->{+AUDITOR_WRITER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+AUDITOR_WRITER}; +} + +sub ipc { + my $self = shift; + return $self->{+IPC} //= Test2::Harness::IPC->new( + handlers => { + INT => sub { $self->handle_sig(@_) }, + TERM => sub { $self->handle_sig(@_) }, + } + ); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + eval { $_->signal($sig) } for grep { $_->can('signal') } @{$self->renderers}; + + print STDERR "\nCaught SIG$sig, forwarding signal to child processes...\n"; + $self->ipc->killall($sig); + + if ($self->{+SIGNAL}) { + print STDERR "\nSecond signal ($self->{+SIGNAL} followed by $sig), exiting now without waiting\n"; + exit 1; + } + + $self->{+SIGNAL} = $sig; +} + +sub monitor_preloads { 0 } + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $plugins = $self->state->plugins; + + if ($self->start()) { + $self->render(); + $self->stop(); + + my $final_data = $self->{+FINAL_DATA} or die "Final data never received from auditor!\n"; + my $pass = $self->{+TESTS_SEEN} && $final_data->{pass}; + $self->render_final_data($final_data); + $self->produce_summary($pass); + + if (@$plugins) { + my %args = ( + settings => $settings, + final_data => $final_data, + pass => $pass ? 1 : 0, + tests_seen => $self->{+TESTS_SEEN} // 0, + asserts_seen => $self->{+ASSERTS_SEEN} // 0, + ); + $_->finish(%args) for @$plugins; + } + + return $pass ? 0 : 1; + } + + $self->stop(); + + return 1; +} + +sub DESTROY { + my $self = shift; + + local ($?, $!, $@, $_); + + my $cleanup = delete $self->{+CLEANUP_SUBS} or return; + for my $sub (@$cleanup) { + eval { $sub->(); 1 } or warn $@; + } +} + +sub write_test_info { + my $self = shift; + + return if $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO}; + + my $info_file = "./.test_info.$$.json"; + link($self->state->state_file, $info_file) or warn "Could not link state file to info file: $!"; + + push @{$self->{+CLEANUP_SUBS}} => sub { + return unless -e $info_file; + unlink($info_file) or die "Could not unlink info file: $!"; + }; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} = 1; +} + +sub start { + my $self = shift; + + $self->ipc->start(); + $self->parse_args; + $self->write_settings_to($self->workdir, 'settings.json'); + + $self->write_test_info(); + my $pop = $self->populate_queue(); + $self->terminate_queue(); + + return unless $pop; + + $self->setup_plugins(); + $self->setup_resources(); + + $self->start_runner(jobs_todo => $pop); + $self->start_collector(); + $self->start_auditor(); + + return 1; +} + +sub render { + my $self = shift; + + my $state = $self->state; + my $ipc = $self->ipc; + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + my $plugins = $self->settings->harness->plugins; + + my $handle_plugins = $state->plugins('handle_event'); + my $annotate_plugins = $state->plugins('annotate_event'); + + # render results from log + my $reader = $self->renderer_reader(); + $reader->blocking(0); + my $buffer; + while (1) { + return if $self->{+SIGNAL}; + $_->step for @{$renderers}; + + my $line = <$reader>; + unless(defined $line) { + $ipc->wait() if $ipc; + sleep 0.02; + next; + } + + if ($buffer) { + $line = $buffer . $line; + $buffer = undef; + } + + unless (substr($line, -1, 1) eq "\n") { + $buffer //= ""; + $buffer .= $line; + next; + } + + my $e = decode_json($line); + + if (defined $e) { + bless($e, 'Test2::Harness::Event'); + my $fd = $e->{facet_data} //= {}; + + my $changed = 0; + for my $p (@$annotate_plugins) { + my %inject = $p->annotate_event($e, $settings); + next unless keys %inject; + $changed++; + + # Can add new facets, but not modify existing ones. + # Someone could force the issue by modifying the event directly + # inside 'annotate_event', this is not supported, but also not + # forbidden, user beware. + for my $f (keys %inject) { + if (exists $fd->{$f}) { + if ('ARRAY' eq ref($fd->{$f})) { + push @{$fd->{$f}} => @{$inject{$f}}; + } + else { + warn "Plugin '$p' tried to add facet '$f' via 'annotate_event()', but it is already present and not a list, ignoring plugin annotation.\n"; + } + } + else { + $fd->{$f} = $inject{$f}; + } + } + + } + + if ($logger) { + if ($changed) { + my $newline = $e->as_json; + print $logger $newline, "\n"; + } + else { + print $logger $line; + } + } + } + else { + last; + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + $_->render_event($e) for @$renderers; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + $_->handle_event($e, $settings) for @$handle_plugins; + + $ipc->wait() if $ipc; + } +} + +sub get_job_pid { + my $self = shift; + my ($run_id, $job_id) = @_; + + return undef unless $run_id && $job_id; + + # { + # runs => { + # job_id => [ + # { ... try 0 ... } + # { ... try 1 ... } + # ], + # }, + # } + my $run_info = $self->state->data->runs->{$run_id} or return undef; + my $job_tries = $run_info->{$job_id} or return undef; + return undef unless @$job_tries; + my $job_info = $job_tries->[-1] or return undef; + + return $job_info->{pid} // undef; +} + +sub stop { + my $self = shift; + + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + + $self->teardown_plugins($renderers, $logger); + if ($logger) { + print $logger "null\n"; + close($logger); + } + + $_->finish() for @$renderers; + + my $ipc = $self->ipc; + + if ($self->{+SIGNAL}) { + print STDERR "Waiting for child processes to exit...\n"; + + my $state = $self->state; + delete $state->{no_poll}; + $state->poll; + my $running = $state->running_tasks; + $state->halt_run($self->{+RUN_ID}); + + for my $task (values %$running) { + next unless $task->{run_id} && $task->{run_id} eq $self->{+RUN_ID}; + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + } + + $ipc->wait(all => 1); + $ipc->stop; + + unless ($settings->display->quiet > 2) { + printf STDERR "\nNo tests were seen!\n" unless $self->{+TESTS_SEEN}; + + printf("\nKeeping work dir: %s\n", $self->workdir) + if $settings->debug->keep_dirs; + + if ($settings->logging->log) { + print "\n"; + print "Wrote log file: " . $settings->logging->log_file . "\n"; + print " (Symlinked to: " . $self->{+LAST_LOG} . ")\n"; + } + + $self->finalize_plugins(); + } +} + +sub terminate_queue { + my $self = shift; + + $self->tasks_queue->end(); + $self->state->end_queue(); +} + +sub build_run { + my $self = shift; + + return $self->{+RUN} if $self->{+RUN}; + + my $settings = $self->settings; + my $dir = $self->workdir; + + my $run = $settings->build(run => 'Test2::Harness::Run'); + + mkdir($run->run_dir($dir)) or die "Could not make run dir: $!"; + chmod_tmp($dir); + + return $self->{+RUN} = $run; +} + +sub run_queue { + my $self = shift; + my $dir = $self->workdir; + return $self->{+RUN_QUEUE} //= Test2::Harness::Util::Queue->new(file => File::Spec->catfile($dir, 'run_queue.jsonl')); +} + +sub tasks_queue { + my $self = shift; + + $self->{+TASKS_QUEUE} //= Test2::Harness::Util::Queue->new( + file => File::Spec->catfile($self->build_run->run_dir($self->workdir), 'queue.jsonl'), + ); +} + +sub finder_args {()} + +sub populate_queue { + my $self = shift; + + my $run = $self->build_run(); + $self->{+RUN_ID} = $run->run_id; + my $settings = $self->settings; + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + + my $state = $self->state; + my $tasks_queue = $self->tasks_queue; + my $plugins = $settings->harness->plugins; + + $state->queue_run($run->queue_item($plugins)); + + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + $state->queue_task($task); + $tasks_queue->enqueue($task); + } + + $state->stop_run($run->run_id); + + return $job_count; +} + +sub produce_summary { + my $self = shift; + my ($pass) = @_; + + my $settings = $self->settings; + + my $time_data = { + start => $settings->harness->start, + stop => time(), + }; + + $time_data->{wall} = $time_data->{stop} - $time_data->{start}; + + my @times = times(); + @{$time_data}{qw/user system cuser csystem/} = @times; + $time_data->{cpu} = sum @times; + + my $cpu_usage = int($time_data->{cpu} / $time_data->{wall} * 100); + + $self->write_summary($pass, $time_data, $cpu_usage); + $self->render_summary($pass, $time_data, $cpu_usage); +} + +sub write_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + my $file = $self->settings->debug->summary or return; + + my $final_data = $self->{+FINAL_DATA}; + + my $failures = @{$final_data->{failed} // []}; + + my %data = ( + %$final_data, + + pass => $pass ? JSON->true : JSON->false, + + total_failures => $failures // 0, + total_tests => $self->{+TESTS_SEEN} // 0, + total_asserts => $self->{+ASSERTS_SEEN} // 0, + + cpu_usage => $cpu_usage, + + times => $time_data, + ); + + require Test2::Harness::Util::File::JSON; + my $jfile = Test2::Harness::Util::File::JSON->new(name => $file); + $jfile->write(\%data); + + print "\nWrote summary file: $file\n\n"; + + return; +} + +sub render_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + return if $self->settings->display->quiet > 1; + + my $final_data = $self->{+FINAL_DATA}; + my $failures = @{$final_data->{failed} // []}; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $self->{+TESTS_SEEN}", + "Assertion Count: $self->{+ASSERTS_SEEN}", + $time_data ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->settings->display->color && USE_ANSI_COLOR) { + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + +sub render_final_data { + my $self = shift; + my ($final_data) = @_; + + return if $self->settings->display->quiet > 1; + + if (my $rows = $final_data->{retried}) { + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + header => ['Job ID', 'Times Run', 'Test File', "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{failed}) { + print "\nThe following jobs failed:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Test File', 'Subtests'], + rows => [map { my $r = [@{$_}]; $r->[2] = stringify_subtest_map($r->[2]) if $r->[2]; $r} @$rows], + ); + print "\n"; + } + + if (my $rows = $final_data->{halted}) { + print "\nThe following jobs requested all testing be halted:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File', "Reason"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{unseen}) { + print "\nThe following jobs never ran:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File'], + rows => $rows, + ); + print "\n"; + } +} + +sub stringify_subtest_map { + my ($map) = @_; + + my $out = ""; + my @todo = @$map; + my @state; + while (my $st = shift @todo) { + if (!ref($st)) { + pop @state if $st eq 'pop'; + next; + } + push @state => $st->[0]; + $out .= join(' -> ' => @state) . "\n"; + unshift @todo => (@{$st->[1]}, 'pop'); + } + + return $out; +} + +sub logger { + my $self = shift; + + return $self->{+LOGGER} if $self->{+LOGGER}; + + my $settings = $self->{+SETTINGS}; + + return unless $settings->logging->log; + + my $file = $settings->logging->log_file; + + if ($settings->logging->bzip2) { + no warnings 'once'; + require IO::Compress::Bzip2; + $self->{+LOGGER} = IO::Compress::Bzip2->new($file) or die "Could not open log file '$file': $IO::Compress::Bzip2::Bzip2Error"; + } + elsif ($settings->logging->gzip) { + no warnings 'once'; + require IO::Compress::Gzip; + $self->{+LOGGER} = IO::Compress::Gzip->new($file) or die "Could not open log file '$file': $IO::Compress::Gzip::GzipError"; + } + else { + $self->{+LOGGER} = open_file($file, '>'); + } + + for my $ext ('jsonl', 'jsonl.bz2', 'jsonl.gz') { + my $name = "./lastlog.$ext"; + next unless -f $name; + local ($!, $@) = (0, ''); + eval { unlink($name) } or warn "Could not unlink '$name': ($!) $@"; + } + + if ($file =~ m/\.(jsonl(?:\.(?:bz2|gz))?)$/) { + my $ext = $1; + my $name = "./lastlog.$ext"; + if (eval { symlink($file, $name); 1 }) { + $self->{+LAST_LOG} = $name; + } + else { + warn "Could not symlink the log file to '$name': $@"; + } + } + + return $self->{+LOGGER}; +} + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + my @renderers; + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub start_auditor { + my $self = shift; + + my $run = $self->build_run(); + my $settings = $self->settings; + + my $ipc = $self->ipc; + $ipc->spawn( + stdin => $self->auditor_reader(), + stdout => $self->auditor_writer(), + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + auditor => 'Test2::Harness::Auditor', + $run->run_id, + procname_prefix => $settings->debug->procname_prefix, + ], + ); + + close($self->auditor_writer()); +} + +sub collector_options { () } + +sub start_collector { + my $self = shift; + + my $dir = $self->workdir; + my $run = $self->build_run(); + my $settings = $self->settings; + my $runner_pid = $self->runner_pid; + + my ($rh, $wh); + pipe($rh, $wh) or die "Could not create pipe"; + + my %options = (show_runner_output => 1); + if ($settings->check_prefix('display')) { + $options{show_runner_output} = $settings->display->hide_runner_output ? 0 : 1; + $options{truncate_runner_output} = $settings->display->truncate_runner_output; + } + + %options = ( + %options, + $self->collector_options(), + ); + + my $ipc = $self->ipc; + $ipc->spawn( + stdout => $self->collector_writer, + stdin => $rh, + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + collector => 'Test2::Harness::Collector', + $dir, $run->run_id, $runner_pid, + %options, + ], + ); + + close($rh); + print $wh encode_json($run) . "\n"; + close($wh); + + close($self->collector_writer()); +} + +sub start_runner { + my $self = shift; + my %args = @_; + + $args{monitor_preloads} //= $self->monitor_preloads; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $ipc = $self->ipc; + my $proc = $ipc->spawn( + stderr => File::Spec->catfile($dir, 'error.log'), + stdout => File::Spec->catfile($dir, 'output.log'), + env_vars => { @prof ? (NYTPROF => 'start=no:addpid=1') : () }, + no_set_pgrp => 1, + command => [ + $^X, @prof, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + %args, + ], + ); + + $self->{+RUNNER_PID} = $proc->pid; + + return $proc; +} + +sub parse_args { + my $self = shift; + my $settings = $self->settings; + my $args = $self->args; + + my $dest = $settings->finder->search; + for my $arg (@$args) { + next if $arg eq '--'; + if ($arg eq '::') { + $dest = $settings->run->test_args; + next; + } + + push @$dest => $arg; + } + + return; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib2.0/App/Yath/Command/versions.pm b/lib2.0/App/Yath/Command/versions.pm new file mode 100644 index 000000000..03c224813 --- /dev/null +++ b/lib2.0/App/Yath/Command/versions.pm @@ -0,0 +1,34 @@ +package App::Yath::Command::versions; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'App::Yath::Command'; + +sub group { '' } +sub summary { 'Show version information' } + +sub description { + return <<" EOT" +This command displays version information. + EOT +} + +sub run { + my $self = shift; + + require App::Yath; + + my $app = App::Yath->new(settings => $self->settings); + print $app->version_info . "\n\n"; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib2.0/App/Yath/Finder.pm b/lib2.0/App/Yath/Finder.pm new file mode 100644 index 000000000..a34c4844a --- /dev/null +++ b/lib2.0/App/Yath/Finder.pm @@ -0,0 +1,911 @@ +package App::Yath::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use List::Util qw/first/; +use Cwd qw/getcwd/; +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Text::ParseWords qw/quotewords/; + +use Test2::Harness::Task::TestFile; +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + +duration_data + search + <run_id + + <settings + <state + + <changed <changed_only <changes_diff <changes_exclude_files + <changes_exclude_loads <changes_exclude_nonsub <changes_exclude_opens + <changes_exclude_patterns <changes_filter_files <changes_filter_patterns + <changes_include_whitespace <changes_plugin <show_changed_files + + <durations <maybe_durations <durations_threshold + <no_long <only_long + + <default_at_search <default_search + + <exclude_files <exclude_lists <exclude_patterns + + <extensions + + <rerun <rerun_modes <rerun_plugins +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" unless $self->{+RUN_ID}; + + delete $self->{class}; + + $self->{+EXCLUDE_FILES} = { map {( $_ => 1 )} @{$self->{+EXCLUDE_FILES}} } if ref($self->{+EXCLUDE_FILES}) eq 'ARRAY'; + + if (my $plugins = $self->{+RERUN_PLUGINS}) { + for (@$plugins) { + $_ = "App::Yath::Plugin::$_" unless s/^\+// or m/^(App::Yath|Test2::Harness)::Plugin::/; + my $file = mod2file($_); + require $file; + } + } + + my @bad = grep { !$self->can(uc($_)) } keys %$self; + + croak "Invalid keys provided to constructor: " . join(", " => @bad) if @bad; +} + +sub duration_data { + my $self = shift; + my ($plugins, $test_files) = @_; + + $self->{+DURATION_DATA} //= $self->pull_durations(); + + return $self->{+DURATION_DATA} if $self->{+DURATION_DATA}; + + for my $plugin (@$plugins) { + next unless $plugin->can('duration_data'); + $self->{+DURATION_DATA} = $plugin->duration_data($self->settings, $test_files) or next; + last; + } + + return $self->{+DURATION_DATA} //= {}; +} + +sub pull_durations { + my $self = shift; + + my $primary = delete $self->{+MAYBE_DURATIONS}; + my $fallback = delete $self->{+DURATIONS}; + + my @args = ( + name => 'durations', + is_json => 1, + http_args => [{headers => {'Content-Type' => 'application/json'}}], + ); + + if ($primary) { + local $@; + + my $durations = eval { $self->_pull_from_file_or_url(source => $primary, @args) } + or print "Could not fetch optional durations '$primary', ignoring...\n"; + + if ($durations) { + print "Found durations: $primary\n"; + return $durations; + } + } + + return $self->_pull_from_file_or_url(source => $fallback, @args) + if $fallback; + + return; +} + +sub add_exclusions_from_lists { + my $self = shift; + + my @lists = ref($self->{+EXCLUDE_LISTS}) eq 'ARRAY' ? @{$self->{+EXCLUDE_LISTS}} : ($self->{+EXCLUDE_LISTS}); + + for my $path (@lists) { + my $content = $self->_pull_from_file_or_url( + source => $path, + name => 'exclusion lists', + ); + + next unless $content; + + for (split(/\r?\n\r?/, $content)) { + $self->{+EXCLUDE_FILES}->{$_} = 1 unless /^\s*#/; + }; + } +} + +sub _pull_from_file_or_url { + my $self = shift; + my %params = @_; + + my $in = $params{source} // croak "No file or url provided"; + my $name = $params{name} // croak "No name provided"; + + my $is_json = $params{is_json}; + + if (my $type = ref($in)) { + return $in if $is_json && ($type eq 'HASH' || $type eq 'ARRAY'); + } + elsif (-f $in) { + if ($is_json) { + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => $in); + return $file->read(); + } + else { + require Test2::Harness::Util::File; + my $f = Test2::Harness::Util::File->new(name => $in); + return $f->read(); + } + } + elsif ($in =~ m{^https?://}) { + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args}; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + my $res = $ht->$meth($in, $args ? (@$args) : ()); + + die "Could not query $name from '$in'\n$res->{status}: $res->{reason}\n$res->{content}\n" + unless $res->{success}; + + return $is_json ? decode_json($res->{content}) : $res->{content}; + } + + die "Invalid $name specification: $in"; +} + +sub find_files { + my $self = shift; + my ($plugins) = @_; + + $self->add_exclusions_from_lists() if $self->{+EXCLUDE_LISTS}; + + my $add_changes = 0; + $add_changes ||= $self->{+CHANGED} && @{$self->{+CHANGED}}; + $add_changes ||= $self->{+CHANGED_ONLY}; + $add_changes ||= $self->{+CHANGES_PLUGIN}; + $add_changes ||= $self->{+CHANGES_DIFF}; + + $self->add_changed_to_search($plugins) if $add_changes; + + my $add_rerun = $self->{+RERUN}; + $self->add_rerun_to_search($plugins, $add_rerun) if $add_rerun; + + return $self->find_project_files($plugins, $self->search); +} + +sub check_plugins { + my $self = shift; + my ($plugins) = @_; + + my $check_plugins = $plugins; + my $plugin; + if (my $p = $self->{+CHANGES_PLUGIN}) { + $plugin = $p =~ s/^\+// ? $p : "App::Yath::Plugin::$p"; + $check_plugins = [$plugin]; + } + + return $check_plugins // []; +} + +sub get_diff { + my $self = shift; + my ($plugins) = @_; + + return (file => $self->{+CHANGES_DIFF}) if $self->{+CHANGES_DIFF}; + + my $check_plugins = $self->check_plugins($plugins); + + for my $plugin (@$check_plugins) { + if ($plugin->can('changed_diff')) { + my ($type, $data) = $plugin->changed_diff($self->settings); + next unless $type && $data; + + return ($type => $data); + } + } + + return (); +} + +sub find_changes { + my $self = shift; + my ($plugins) = @_; + + my @listed_changes; + @listed_changes = @{$self->{+CHANGED}} if $self->{+CHANGED}; + + my ($type, $diff) = $self->get_diff($plugins); + + my (@found_changes); + if ($type && $diff) { + @found_changes = $self->changes_from_diff($type => $diff); + } + + unless (@found_changes) { + my $check_plugins = $self->check_plugins($plugins); + + for my $plugin (@$check_plugins) { + next unless $plugin->can('changed_files'); + + push @found_changes => $plugin->changed_files($self->settings); + last if @found_changes; + } + } + + my $filter_patterns = @{$self->{+CHANGES_FILTER_PATTERNS}} ? $self->{+CHANGES_FILTER_PATTERNS} : undef; + my $filter_files = @{$self->{+CHANGES_FILTER_FILES}} ? {map { $_ => 1 } @{$self->{+CHANGES_FILTER_FILES}}} : undef; + + my $exclude_patterns = @{$self->{+CHANGES_EXCLUDE_PATTERNS}} ? $self->{+CHANGES_EXCLUDE_PATTERNS} : undef; + my $exclude_files = @{$self->{+CHANGES_EXCLUDE_FILES}} ? {map { $_ => 1 } @{$self->{+CHANGES_EXCLUDE_FILES}}} : undef; + + my %changed_map; + for my $change (@listed_changes, @found_changes) { + next unless $change; + my ($file, @parts) = ref($change) ? @$change : ($change); + + next if $filter_files && !$filter_files->{$file}; + next if $exclude_files && $exclude_files->{$file}; + next if $filter_patterns && !first { $file =~ m/$_/ } @$filter_patterns; + next if $exclude_patterns && first { $file =~ m/$_/ } @$exclude_patterns; + + @parts = ('*') unless @parts; + $changed_map{$file}{$_} = 1 for @parts; + } + + return \%changed_map; +} + +sub get_capable_plugins { + my $self = shift; + my ($method, $plugins) = @_; + + my %seen; + return grep { $_ && !$seen{$_}++ && $_->can($method) } @$plugins; +} + +sub add_rerun_to_search { + my $self = shift; + my ($plugins, $rerun) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $modes = $self->{+RERUN_MODES}; + my $mode_hash = { map {$_ => 1} @$modes }; + + my ($grabbed, $data); + for my $p ($self->get_capable_plugins(grab_rerun => [@{$self->{+RERUN_PLUGINS} // []}, @$plugins])) { + ($grabbed, $data) = $p->grab_rerun($rerun, modes => $modes, mode_hash => $mode_hash, settings => $self->settings); + next unless $grabbed; + + unless ($data && keys %$data) { + print "No files found to rerun.\n"; + exit 0; + } + + last if $grabbed; + } + + unless ($grabbed) { + if ($rerun eq '1') { + $rerun = first { -e $_ } qw{ ./lastlog.jsonl ./lastlog.jsonl.bz2 ./lastlog.jsonl.gz }; + + die "Could not find a lastlog.jsonl(.bz2|.gz) file for re-running, you may need to provide a full path to --rerun=... or --rerun-failed=..." + unless $rerun; + } + + die "'$rerun' is not a valid log file, and no plugin intercepted it.\n" unless -f $rerun; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $rerun, skip_bad_decode => 1); + + my %files; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $f = $event->{facet_data} or next; + + for my $type (qw/seen queued start end/) { + my $field = $type eq 'seen' ? "harness_job" : "harness_job_$type"; + + my $data = $f->{$field} or next; + + my $file = $data->{rel_file} // $data->{run_file} // $data->{file} // $data->{abs_file}; + next unless $file; + + my $ref = $files{$file} //= {}; + $ref->{$type}++; + + $ref->{$data->{fail} ? 'fail' : 'pass'}++ if $type eq 'end'; + $ref->{retry}++ if $data->{is_try}; + } + } + } + + $data = \%files; + } + + my @add = map { $data->{$_}->{add} // $_ } grep { + my $entry = $data->{$_}; + + my $keep = $mode_hash->{all} ? 1 : 0; + $keep ||= 1 if $mode_hash->{failed} && $entry->{fail} && !$entry->{pass}; + $keep ||= 1 if $mode_hash->{retried} && $entry->{retry}; + $keep ||= 1 if $mode_hash->{passed} && $entry->{pass}; + $keep ||= 1 if $mode_hash->{missed} && !$entry->{end}; + + $keep + } sort keys %$data; + + unless (@add) { + print "No files found to rerun.\n"; + exit 0; + } + + push @$search => @add; +} + +sub add_changed_to_search { + my $self = shift; + my ($plugins) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $changed_map = $self->find_changes($plugins); + my $found_changed = keys %$changed_map; + + die "Could not find any changed files.\n" if $self->{+CHANGED_ONLY} && !$found_changed; + + if ($self->{+CHANGED_ONLY}) { + die "Can not add test or directory names when using --changed-only (saw: " . join(", " => @$search) . ")\n" + if @$search; + } + + if ($self->{+SHOW_CHANGED_FILES} && $found_changed) { + print "Found the following changed files:\n"; + for my $file (keys %$changed_map) { + print " $file: ", join(", ", sort keys %{$changed_map->{$file}}), "\n"; + } + } + + my @add; + for my $p ($self->get_capable_plugins(get_coverage_tests => $plugins)) { + for my $set ($p->get_coverage_tests($self->settings, $changed_map)) { + my $test = ref($set) ? $set->[0] : $set; + + unless (-e $test) { + print STDERR "Coverage wants to run test '$test', but it does not exist, skipping...\n"; + next; + } + + push @add => $set; + } + } + + for my $p ($self->get_capable_plugins(post_process_coverage_tests => $plugins)) { + $p->post_process_coverage_tests($self->settings, \@add); + } + + if ($self->{+SHOW_CHANGED_FILES} && @add) { + print "Found " . scalar(@add) . " test files to run based on changed files.\n"; + print ref($_) ? " $_->[0]" : " $_\n" for @add; + print "\n"; + } + + push @$search => @add; + + return; +} + +sub changes_from_diff { + my $self = shift; + my ($type, $data) = @_; + + my $next; + if ($type eq 'lines') { + $next = sub { shift @$data }; + } + elsif ($type eq 'diff') { + my $lines = [split /\n/, $data]; + $next = sub { shift @$lines }; + } + elsif ($type eq 'file') { + die "'$data' is not a valid diff file.\n" unless -f $data; + open(my $fh, '<', $data) or die "Could not open diff file '$data': $!"; + $next = sub { + my $line = <$fh>; + close($fh) unless defined $line; + return $line; + }; + } + elsif ($type eq 'line_sub') { + $next = $data; + } + elsif ($type eq 'handle') { + $next = sub { scalar <$data> }; + } + else { + die "Invalid diff type '$type'"; + } + + my %changed; + + # Only perl can parse perl, and nothing can parse perl diff. What this does + # is take a diff of every file with 100% context so we see the entire file + # with the +, minus, or space prefix. As we scan it we look for subs. We + # track what files and subs we are in. When we see a change we + # {$file}{$sub}++. + # + # This of course is broken if you make a change between + # subs as it will attribute it to the previous sub, however tracking + # indentation is equally flawed as things like heredocs and other special + # perl things can also trigger that to prematurely think we are out of a + # sub. + # + # PPI and similar do a better job parsing perl, but using them and also + # tracking changes from the diff, or even asking them to parse a diff where + # some lines are added and others removed is also a huge hassle. + # + # The current algorith is "good enough", not perfect. + my ($file, $sub, $indent, $is_perl); + while (my $line = $next->()) { + chomp($line); + if ($line =~ m{^(?:---|\+\+\+) ([ab]/)?(.*)$}) { + my $maybe_prefix = $1; + my $maybe_file = $2; + next if $maybe_file =~ m{/dev/null}; + if ($maybe_prefix) { + $file = -f "$maybe_prefix$maybe_file" ? "$maybe_prefix$maybe_file" : $maybe_file; + } + else { + $file = $maybe_file; + } + $is_perl = 1 if $file =~ m/\.(pl|pm|t2?)$/; + $sub = '*'; # Wildcard, changes to the code outside of a sub potentially effects all subs + next; + } + + next unless $file; + + $line =~ m/^( |-|\+)(.*)$/ or next; + my ($prefix, $statement) = ($1, $2); + my $changed = $prefix eq ' ' ? 0 : 1; + + $is_perl = 1 if $statement =~ m/^#!.*perl/; + + if ($statement =~ m/^(\s*)sub\s+(\w+)/) { + $indent = $1 // ''; + $sub = $2; + + # 1-line sub: sub foo { ... } + if ($statement =~ m/}/) { + $changed{$file}{$sub}++ if $changed; + $sub = '*'; + $indent = undef; + next; + } + } + elsif(defined($indent) && $statement =~ m/^$indent\}/) { + $indent = undef; + $sub = "*"; + + # If this is nothing but whitespace and a closing paren we can skip it. + next if $statement =~ m/^\s*\}?\s*$/ && !$self->{+CHANGES_INCLUDE_WHITESPACE}; + } + + next unless $sub; # If sub is empty then we are not even in a file yet + next unless $changed; # If we are not on a changed line no need to add it + unless ($self->{+CHANGES_INCLUDE_WHITESPACE}) { + next if !length($statement); # If there is no statement length then this is whitespace only + next if $statement =~ m/^\s+$/; # Do not care about whitespace only changes + } + + next if $is_perl && $self->{+CHANGES_EXCLUDE_NONSUB} && $sub eq '*'; + + $changed{$file}{$sub}++; + } + + return map {([$_ => sort keys %{$changed{$_}}])} sort keys %changed; +} + +sub find_project_files { + my $self = shift; + my ($plugins, $input) = @_; + + $input //= []; + $plugins //= []; + + my $settings = $self->settings; + my $default_search = [@{$self->default_search}]; + push @$default_search => @{$self->default_at_search} if $settings->check_group('run') && $settings->run->author_testing; + + $_->munge_search($input, $default_search, $settings) for @$plugins; + + my $search = @$input ? $input : $self->{+CHANGED_ONLY} ? [] : $default_search; + + die "No tests to run, search is empty\n" unless @$search; + + my $harness = $self->state; + + my (%seen, @tests, @dirs); + + for my $item (@$search) { + my ($path, $test_params); + + if (ref $item) { + ($path, $test_params) = @$item; + } + else { + my ($type, $data); + ($path, $type, $data) = split /(:<|:@|:=)/, $item, 2; + if ($type && $data) { + $test_params = {}; + if ($type eq ':<') { + $test_params->{stdin} = $data; + } + elsif ($type eq ':@') { + $test_params->{argv} = decode_json($data); + } + elsif ($type eq ':=') { + $test_params->{env} = decode_json($data); + } + } + } + + push @dirs => $path and next if -d $path; + + unless(-f $path) { + my ($actual, $args) = split /=/, $path, 2; + if (-f $actual) { + $path = $actual; + $test_params = {%{$test_params // {}}, argv => [quotewords('\s+', 0, $args)]}; + } + else { + die "'$path' is not a valid file or directory.\n" if @$input; + next; + } + } + + $path = clean_path($path, 0); + $seen{$path}++; + + my $job_id = gen_uuid(); + my $test; + unless (first { $test = $_->claim_file($path, $settings, from => 'listed') } @$plugins) { + my $test = $harness->shared_init( + 'task', $self->run_id, $job_id, + class => 'Test2::Harness::Task::TestFile', + file => $path, + run_id => $self->run_id, + job_id => $job_id, + ); + } + + if (my @exclude = $self->exclude_file($test)) { + $harness->shared_delete('Task', $self->run_id, $job_id); + if (@$input) { + print STDERR "File '$path' was listed on the command line, but has been exluded for the following reasons:\n"; + print STDERR " $_\n" for @exclude; + } + + next; + } + + if ($test_params) { + $test->set_input($test_params->{stdin}) if $test_params->{stdin}; + $test->set_test_args($test_params->{argv}) if $test_params->{argv}; + $test->set_env_vars($test_params->{env}) if $test_params->{env}; + } + + push @tests => $test; + } + + if (@dirs) { + require File::Find; + File::Find::find( + { + no_chdir => 1, + wanted => sub { + no warnings 'once'; + + my $file = clean_path($File::Find::name, 0); + + return if $seen{$file}++; + return unless -f $file; + + my $test; + unless(first { $test = $_->claim_file($file, $settings, from => 'search') } @$plugins) { + for my $ext (@{$self->extensions}) { + next unless m/\.\Q$ext\E$/; + + my $job_id = gen_uuid(); + $test = $harness->shared_init( + task => $self->run_id => $job_id, + class => 'Test2::Harness::Task::TestFile', + file => $file, + run_id => $self->run_id, + job_id => $job_id, + ); + + last; + } + } + + return unless $test; + return unless $self->include_file($test); + push @tests => $test; + }, + }, + @dirs + ); + } + + my $test_count = @tests; + my $threshold = $self->durations_threshold // 0; + if ($threshold && $test_count >= $threshold) { + my $start = time; + my $durations = $self->duration_data($plugins, $settings, [map { $_->relative } @tests]); + my $end = time; + if ($durations && keys %$durations) { + printf("Fetched duration data (Took %0.2f seconds)\n", $end - $start); + for my $test (@tests) { + my $rel = $test->relative; + $test->set_duration($durations->{$rel}) if $durations->{$rel}; + } + } + } + + $_->munge_files(\@tests, $settings) for @$plugins; + + return @tests; + return [ sort { $a->rank <=> $b->rank || $a->file cmp $b->file } @tests ]; +} + +sub include_file { + my $self = shift; + my ($test) = @_; + + my @exclude = $self->exclude_file($test); + + return !@exclude; +} + +sub exclude_file { + my $self = shift; + my ($test) = @_; + + warn "FIXME"; + return; + + my @out; + + push @out => "File has a do-not-run directive inside it." unless $test->check_feature(run => 1); + + my $full = $test->file; + my $rel = $test->relative; + + push @out => 'File is in the exclude list.' if $self->exclude_files->{$full} || $self->exclude_files->{$rel}; + push @out => 'File matches an exclusion pattern.' if first { $rel =~ m/$_/ } @{$self->exclude_patterns}; + + push @out => 'File is marked as "long", but the "no long tests" opition was specified.' + if $self->no_long && $test->check_duration eq 'long'; + + push @out => 'File is not marked "long", but the "only long tests" option was specified.' + if $self->only_long && $test->check_duration ne 'long'; + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Finder - Library that searches for test files + +=head1 DESCRIPTION + +The finder is responsible for locating test files that should be run. You can +subclass the finder and instruct yath to use your subclass. + +=head1 SYNOPSIS + +=head2 USING A CUSTOM FINDER + +To use App::Yath::Finder::MyFinder: + + $ yath test --finder MyFinder + +To use Another::Finder + + $ yath test --finder +Another::Finder + +By default C<App::Yath::Finder::> is prefixed onto your custom finder, use +'+' before the class name or prevent this. + +=head2 SUBCLASSING + + use parent 'App::Yath::Finder'; + use Test2::Harness::Task::TestFile; + + # Custom finders may provide their own options if desired. + # This is optional. + use App::Yath::Options; + option foo => ( + ... + ); + + # This is the main method to override. + sub find_project_files { + my $self = shift; + my ($plugins, $search) = @_; + + return [ + Test2::Harness::Task::TestFile->new(...), + Test2::Harness::Task::TestFile->new(...), + ..., + ]; + } + +=head1 METHODS + +These are important state methods, as well as utility methods for use in your +subclasses. + +=over 4 + +=item $arrayref = $finder->find_files($plugins) + +This is the main method. This method returns an arrayref of +L<Test2::Harness::Task::TestFile> instances, each one representing a single test to +run. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +B<Note:> In many cases it is better to override C<find_project_files()> in your +subclasses. + +=item $durations = $finder->duration_data + +This will fetch the durations data if any was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +B<Note:> The result is cached, see L<pull_durations()> to refresh the data. + +=item @reasons = $finder->exclude_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This will +return a list of human readible reasons a test file should be excluded. If the +file should not be excluded the list will be empty. + +This is a utility method that verifies the file is not in an exclude +list/pattern. The reasons are provided back in case you need to inform the +user. + +=item $bool = $finder->include_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This is a +convenience method around C<exclude_file()>, it will return true when +C<exclude_file()> returns an empty list. + +=item $arrayref = $finder->find_project_files($plugins, $search) + +These do the heavy lifting for C<find_files> + +The default C<find_files()> implementation is this: + + sub find_files { + my $self = shift; + my ($plugins) = @_; + + return $self->find_project_files($plugins, $self->search); + } + +Each one returns an arrayref of L<Test2::Harness::Task::TestFile> instances. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$search is an arrayref of search paths. + +=item $finder->pull_durations + +This will fetch the durations data if ant was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +L<duration_data()> is a cached version of this. This method will refresh the +cache for the other. + +=back + +=head2 FROM SETTINGS + +See L<App::Yath::Options::Finder> for up to date documentation on these. + +=over 4 + +=item $finder->default_search + +=item $finder->default_at_search + +=item $finder->durations + +=item $finder->maybe_durations + +=item $finder->exclude_files + +=item $finder->exclude_patterns + +=item $finder->no_long + +=item $finder->only_long + +=item $finder->search + +=item $finder->extensions + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Finder/MultiProject.pm b/lib2.0/App/Yath/Finder/MultiProject.pm new file mode 100644 index 000000000..3d2bb7dec --- /dev/null +++ b/lib2.0/App/Yath/Finder/MultiProject.pm @@ -0,0 +1,56 @@ +package App::Yath::Finder::MultiFile; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/clean_path/; +use Cwd qw/getcwd/; +use File::Spec; + +use parent 'App::Yath::Finder'; +use Test2::Harness::Util::HashBase; + +sub find_project_files { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search // []; + + die "multi-project search must be a single directory, or the current directory" if @$search > 1; + my ($pdir) = @$search; + my $dir = clean_path(getcwd()); + + my $out = []; + my $ok = eval { + chdir($pdir) if defined $pdir; + my $ret = clean_path(getcwd()); + + opendir(my $dh, '.') or die "Could not open project dir: $!"; + for my $subdir (readdir($dh)) { + chdir($ret); + + next if $subdir =~ m/^\./; + my $path = clean_path(File::Spec->catdir($ret, $subdir)); + next unless -d $path; + + chdir($path) or die "Could not chdir to $path: $!\n"; + + for my $item (@{$self->SUPER::find_project_files($plugins, $settings, [])}) { + push @{$item->queue_args} => ('ch_dir' => $path); + push @$out => $item; + } + } + + chdir($ret); + 1; + }; + my $err = $@; + + chdir($dir); + die $err unless $ok; + + return $out; +} + +1; diff --git a/lib2.0/App/Yath/Harness.pm b/lib2.0/App/Yath/Harness.pm new file mode 100644 index 000000000..db13e9f9c --- /dev/null +++ b/lib2.0/App/Yath/Harness.pm @@ -0,0 +1,34 @@ +package App::Yath::Harness; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/mod2file clean_path/; +use Getopt::Yath::Settings; + +use Time::HiRes qw/sleep/; + +use parent 'Test2::Harness'; +use Test2::Harness::Util::IPC::TxnState qw{ + +settings + runner_cli +}; + +sub shared_types { + my $self = shift; + + my $types = $self->SUPER::shared_types(); + + return { + %$types, + renderer => {class => 'Test2::Harness::Renderer', single => 0}, + }; +} + +sub settings { + my $self = shift; + $self->transaction(r => sub { Getopt::Yath::Settings->new($self->data->{settings}) }); +} + +1; diff --git a/lib2.0/App/Yath/Options.pm b/lib2.0/App/Yath/Options.pm new file mode 100644 index 000000000..946530f54 --- /dev/null +++ b/lib2.0/App/Yath/Options.pm @@ -0,0 +1,25 @@ +package App::Yath::Options; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +sub import { deprecated() } + +sub deprecated { die(<<"EOT") } + +*************************************** +** App::Yath::Options is deprecated! ** +*************************************** + +Yath plugins, commands, and similar should use Getopt::Yath instead. + +If you are seeing this message it means one or more of your yath plugins or +commands are not compatible with the newest version of yath, and must be +updated. + +*************************************** + +EOT + +1; diff --git a/lib2.0/App/Yath/Options/Finder.pm b/lib2.0/App/Yath/Options/Finder.pm new file mode 100644 index 000000000..94e5511ad --- /dev/null +++ b/lib2.0/App/Yath/Options/Finder.pm @@ -0,0 +1,282 @@ +package App::Yath::Options::Finder; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/fqmod/; +use Getopt::Yath; + +my %RERUN_MODES = ( + all => "Re-Run all tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + failed => "Re-Run failed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + retried => "Re-Run retried tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + passed => "Re-Run passed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + missed => "Run missed tests from a previously aborted/stopped run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", +); + +option_group {group => 'finder', category => "Finder Options"} => sub { + option class => ( + name => 'finder', + field => 'class', + type => 'Scalar', + default => 'App::Yath::Finder', + + mod_adds_options => 1, + long_examples => [' MyFinder', ' +App::Yath::Finder::MyFinder'], + description => 'Specify what Finder subclass to use when searching for files/processing the file list. Use the "+" prefix to specify a fully qualified namespace, otherwise App::Yath::Finder::XXX namespace is assumed.', + + normalize => sub { fqmod('App::Yath::Finder', $_[0]) }, + ); + + option extensions => ( + type => 'List', + alt => ['ext', 'extension'], + split_on => ',', + + description => 'Specify valid test filename extensions, default: t and t2', + normalize => sub { $_[0] =~ s/^\.+//g; $_[0] }, + default => sub { qw/t t2/ }, + ); + + option no_long => ( + type => 'Bool', + + description => "Do not run tests that have their duration flag set to 'LONG'", + ); + + option only_long => ( + type => 'Bool', + + description => "Only run tests that have their duration flag set to 'LONG'", + ); + + option show_changed_files => ( + type => 'Bool', + + description => "Print a list of changed files if any are found", + ); + + option changed_only => ( + type => 'Bool', + + description => "Only search for tests for changed files (Requires a coverage data source, also requires a list of changes either from the --changed option, or a plugin that implements changed_files() or changed_diff())", + ); + + option rerun => ( + type => 'Auto', + + description => "Re-Run tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + + autofill => sub { + my $log = first { -e $_ } qw{ ./lastlog.jsonl ./lastlog.jsonl.bz2 ./lastlog.jsonl.gz }; + return $log // './lastlog.jsonl'; + }, + ); + + option rerun_plugins => ( + type => 'List', + alt => ['rerun_plugin'], + + description => "What plugin(s) should be used for rerun (will fallback to other plugins if the listed ones decline the value, this is just used to set an order of priority)", + long_examples => [' Foo', ' +App::Yath::Plugin::Foo'], + + mod_adds_options => 1, + normalize => sub { fqmod('App::Yath::Plugin', $_[0]) }, + ); + + my $modes = join '|' => sort keys %RERUN_MODES; + option rerun_modes => ( + type => 'BoolMap', + + default => sub { all => 1 }, + + pattern => qr/rerun-($modes)(=.+)?/, + + long_examples => [' ' . join(',', sort keys %RERUN_MODES)], + + requires_arg => 1, + + normalize => sub { + map { die "'$_' is not a valid run mode" unless $RERUN_MODES{$_}; $_ => 1 } split /[\s,]+/, $_[0]; + }, + + description => ["Pick which test categories to run.", map { sprintf("%-8s %s", "$_:", $RERUN_MODES{$_}) } sort keys %RERUN_MODES], + + trigger => sub { + my $opt = shift; + my %params = @_; + return unless $params{action} eq 'set'; + $params{settings}->finder->rerun(1) unless $params{settings}->finder->rerun; + }, + + custom_matches => sub { + my $opt = shift; + my ($input, $state) = @_; + + my $pattern = $opt->pattern; + + return unless $input =~ $pattern; + + my ($no, $key, $val) = ($1, $2, $3); + + if ($val) { + $val =~ s/^=//; + $state->{settings}->finder->rerun($val); + } + + return ($opt, 1, [$key => $no ? 0 : 1]); + }, + + notes => "This will turn on the 'rerun' option. If the --rerun-MODE form is used, you can specify the log file with --rerun-MODE=logfile.", + ); + + option changed => ( + type => 'List', + split_on => ',', + description => "Specify one or more files as having been changed.", + long_examples => [' path/to/file'], + ); + + option changes_exclude_files => ( + alt => ['changes_exclude_file'], + type => 'List', + split_on => ',', + description => 'Specify one or more files to ignore when looking at changes', + long_examples => [' path/to/file'], + ); + + option changes_exclude_patterns => ( + alt => ['changes_exclude_pattern'], + type => 'List', + split_on => ',', + description => 'Ignore files matching this pattern when looking for changes. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + ); + + option changes_filter_files => ( + alt => ['changes_filter_file'], + type => 'List', + split_on => ',', + description => 'Specify one or more files to check for changes. Changes to other files will be ignored', + long_examples => [' path/to/file'], + ); + + option changes_filter_patterns => ( + alt => ['changes_filter_pattern'], + type => 'List', + split_on => ',', + description => 'Specify a pattern for change checking. When only running tests for changed files this will limit which files are checked for changes. Only files that match this pattern will be checked. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + ); + + option changes_diff => ( + type => 'Scalar', + description => "Path to a diff file that should be used to find changed files for use with --changed-only. This must be in the same format as `git diff -W --minimal -U1000000`", + long_examples => [' path/to/diff.diff'], + ); + + option changes_plugin => ( + type => 'Scalar', + description => "What plugin should be used to detect changed files.", + long_examples => [' Git', ' +App::Yath::Plugin::Git'], + ); + + option changes_include_whitespace => ( + type => 'Bool', + description => "Include changed lines that are whitespace only (default: off)", + default => 0, + ); + + option changes_exclude_nonsub => ( + type => 'Bool', + description => "Exclude changes outside of subroutines (perl files only) (default: off)", + default => 0, + ); + + option changes_exclude_loads => ( + type => 'Bool', + description => "Exclude coverage tests which only load changed files, but never call code from them. (default: off)", + default => 0, + ); + + option changes_exclude_opens => ( + type => 'Bool', + description => "Exclude coverage tests which only open() changed files, but never call code from them. (default: off)", + default => 0, + ); + + option durations => ( + type => 'Scalar', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option maybe_durations => ( + type => 'Scalar', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option durations_threshold => ( + type => 'Scalar', + alt => ['Dt'], + default => 0, + description => "Only fetch duration data if running at least this number of tests. Default: 0" + ); + + option exclude_files => ( + alt => ['exclude_file'], + type => 'List', + field => 'exclude_files', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a file from testing", + ); + + option exclude_patterns => ( + alt => ['exclude_pattern'], + type => 'List', + field => 'exclude_patterns', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a pattern from testing, matched using m/\$PATTERN/", + ); + + option exclude_lists => ( + alt => ['exclude_list'], + type => 'List', + + long_examples => [' file.txt', ' http://example.com/exclusions.txt'], + short_examples => [' file.txt', ' http://example.com/exclusions.txt'], + + description => "Point at a file or url which has a new line separated list of test file names to exclude from testing. Starting a line with a '#' will comment it out (for compatibility with Test2::Aggregate list files).", + ); + + option default_search => ( + type => 'List', + default => sub { './t', './t2', './test.pl' }, + + description => "Specify the default file/dir search. defaults to './t', './t2', and 'test.pl'. The default search is only used if no files were specified at the command line", + ); + + option default_at_search => ( + type => 'List', + default => sub { './xt' }, + + description => "Specify the default file/dir search when 'AUTHOR_TESTING' is set. Defaults to './xt'. The default AT search is only used if no files were specified at the command line", + ); +}; + +1; diff --git a/lib2.0/App/Yath/Options/Harness.pm b/lib2.0/App/Yath/Options/Harness.pm new file mode 100644 index 000000000..50e2dddfa --- /dev/null +++ b/lib2.0/App/Yath/Options/Harness.pm @@ -0,0 +1,142 @@ +package App::Yath::Options::Harness; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries mod2file clean_path chmod_tmp/; + +use File::Temp qw/tempdir/; + +use Errno qw/EINTR/; + +use Getopt::Yath; + +option_group {group => 'harness', category => 'Harness Options'} => sub { + option dummy => ( + type => 'Bool', + short => 'd', + description => 'Dummy run, do not actually execute anything', + from_env_vars => [qw/T2_HARNESS_DUMMY/], + clear_env_vars => [qw/T2_HARNESS_DUMMY/], + default => 0, + ); + + option procname_prefix => ( + type => 'Scalar', + default => '', + description => 'Add a prefix to all proc names (as seen by ps).', + ); + + option keep_dirs => ( + type => 'Bool', + short => 'k', + alt => ['keep_dir'], + description => 'Do not delete directories when done. This is useful if you want to inspect the directories used for various commands.', + default => 0, + ); + + option tmpdir => ( + type => 'Scalar', + alt => ['tmp_dir'], + description => 'Use a specific temp directory (Default: use system temp dir)', + from_env_vars => [qw/T2_HARNESS_TEMP_DIR YATH_TEMP_DIR TMPDIR TEMPDIR TMP_DIR TEMP_DIR/], + clear_env_vars => [qw/T2_HARNESS_TEMP_DIR YATH_TEMP_DIR/], + default => sub { File::Spec->tmpdir }, + ); + + option workdir => ( + type => 'Scalar', + description => 'Set the work directory (Default: new temp directory)', + from_env_vars => [qw/T2_WORKDIR YATH_WORKDIR/], + clear_env_vars => [qw/T2_WORKDIR YATH_WORKDIR/], + normalize => \&clean_path, + + trigger => sub { + my $opt = shift; + my %params = @_; + + return unless $params{action} eq 'set'; + + my $val = $params{val} or return; + my ($workdir) = @$val; + + unless (-d $workdir) { + mkdir($workdir) or die "Could not create workdir: $!"; + } + + chmod_tmp($workdir); + + return $workdir; + }, + + default => sub { + my $opt = shift; + my ($settings) = @_; + + my $template = join '-' => ("yath", $$, "XXXXXX"); + + my $workdir = tempdir( + $template, + DIR => $settings->harness->tmpdir, + CLEANUP => 0, + ); + + chmod_tmp($workdir); + + return $workdir; + }, + ); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Harness - Options for any command that interacts with the harness API + +=head1 DESCRIPTION + +Options for any command that interacts with the harness API. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2023 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Options/Renderer.pm b/lib2.0/App/Yath/Options/Renderer.pm new file mode 100644 index 000000000..4f352a336 --- /dev/null +++ b/lib2.0/App/Yath/Options/Renderer.pm @@ -0,0 +1,146 @@ +package App::Yath::Options::Renderer; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/mod2file fqmod/; + +use Getopt::Yath; + +option_group {group => 'renderer', category => "Renderer Options"} => sub { + warn "Help does not seem to show what env vars set this?"; + option color => ( + type => 'Bool', + short => 'c', + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + set_env_vars => ['YATH_COLOR'], + from_env_vars => ['YATH_COLOR', 'CLICOLOR_FORCE'], + ); + + option quiet => ( + type => 'Bool', + short => 'q', + description => "Be very quiet.", + default => 0, + ); + + option verbose => ( + type => 'Count', + short => 'v', + description => "Be more verbose", + default => 0, + ); + + option qvf => ( + type => 'Bool', + default => 0, + description => "Toggles both 'quiet' and 'verbose' which a renderer should accept to mean 'quiet on success, verbose on failure'.", + trigger => sub { + my $opt = shift; + my %params = @_; + if ($params{action} eq 'set') { + $params{group}->{quiet} ||= 1; + $params{group}->{verbose} ||= 1; + } + else { + $params{group}->{quiet} = 0; + $params{group}->{verbose} = 0; + } + }, + ); + + option progress => ( + type => 'Bool', + default => sub { -t STDOUT ? 1 : 0 }, + description => "Toggle progress indicators. On by default if STDOUT is a TTY. You can use --no-progress to disable the 'events seen' counter and buffered event pre-display", + ); + + option wrap => ( + type => 'Bool', + default => 1, + description => "When active (default) renderers should try to wrap text in a human-friendly way. When this is turned off they should just throw text at the terminal." + ); + + option show_times => ( + type => 'Bool', + short => 'T', + description => 'Show the timing data for each job.', + ); + + option hide_runner_output => ( + type => 'Bool', + default => 0, + description => 'Hide output from the runner, showing only test output. (See Also truncate_runner_output)', + ); + + option truncate_runner_output => ( + type => 'Bool', + default => 0, + description => 'Only show runner output that was generated after the current command. This is only useful with a persistent runner.', + ); + + warn "FIXME make sure env var is set for tests too"; + option term_width => ( + type => 'Scalar', + alt => ['term-size'], + description => 'Alternative to setting $TABLE_TERM_SIZE. Setting this will override the terminal width detection to the number of characters specified.', + long_examples => [' 80', ' 200'], + set_env_vars => ['TABLE_TERM_SIZE'], + from_env_vars => ['TABLE_TERM_SIZE'], + ); + + option classes => ( + type => 'Map', + name => 'renderers', + field => 'classes', + alt => ['renderer'], + + description => 'Specify renderers. Use "+" to give a fully qualified module name. Without "+" "App::Yath::Renderer::" will be prepended to your argument.', + + long_examples => [' +My::Renderer', ' MyRenderer,MyOtherRenderer', ' MyRenderer=opt1,opt2', ' :{ MyRenderer :{ opt1 opt2 }: }:', '=:{ MyRenderer opt1,opt2,... }:'], + short_examples => ['MyRenderer', ' +My::Renderer', ' MyRenderer,MyOtherRenderer', ' MyRenderer=opt1,opt2', ' :{ MyRenderer :{ opt1 opt2 }: }:', '=:{ MyRenderer opt1,opt2,... }:'], + initialize => sub { {'App::Yath::Renderer::Default' => []} }, + + normalize => sub { fqmod('App::Yath::Renderer', $_[0]), ref($_[1]) ? $_[1] : [split(',', $_[1] // '')] }, + + mod_adds_options => 1, + ); + + option show_job_end => ( + type => 'Bool', + default => 1, + + description => 'Show output when a job ends. (Default: on)', + ); + + option show_job_info => ( + type => 'Bool', + default => sub { my $v = $_[1]->renderer->verbose // 0; $v > 1 ? 1 : 0 }, + + description => 'Show the job configuration when a job starts. (Default: off, unless -vv)', + ); + + option show_job_launch => ( + type => 'Bool', + default => sub { my $v = $_[1]->renderer->verbose // 0; $v ? 1 : 0 }, + + description => "Show output for the start of a job. (Default: off unless -v)", + ); + + option show_run_info => ( + type => 'Bool', + default => sub { my $v = $_[1]->renderer->verbose // 0; $v > 1 ? 1 : 0 }, + + description => 'Show the run configuration when a run starts. (Default: off, unless -vv)', + ); +}; + +1; + +__END__ + + + + diff --git a/lib2.0/App/Yath/Options/Resource.pm b/lib2.0/App/Yath/Options/Resource.pm new file mode 100644 index 000000000..b7837bc4c --- /dev/null +++ b/lib2.0/App/Yath/Options/Resource.pm @@ -0,0 +1,29 @@ +package App::Yath::Options::Resource; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/mod2file fqmod/; + +use Getopt::Yath; + +option_group {group => 'resource', category => "Resource Options"} => sub { + option classes => ( + type => 'Map', + name => 'resources', + field => 'classes', + alt => ['resource'], + + description => 'Specify resources. Use "+" to give a fully qualified module name. Without "+" "App::Yath::Resource::" will be prepended to your argument.', + + long_examples => [' +My::Resource', ' MyResource,MyOtherResource', ' MyResource=opt1,opt2', ' :{ MyResource :{ opt1 opt2 }: }:', '=:{ MyResource opt1,opt2,... }:'], + short_examples => ['MyResource', ' +My::Resource', ' MyResource,MyOtherResource', ' MyResource=opt1,opt2', ' :{ MyResource :{ opt1 opt2 }: }:', '=:{ MyResource opt1,opt2,... }:'], + + normalize => sub { fqmod('App::Yath::Resource', $_[0]), ref($_[1]) ? $_[1] : [split(',', $_[1] // '')] }, + + mod_adds_options => 1, + ); +}; + +1; diff --git a/lib2.0/App/Yath/Options/Run.pm b/lib2.0/App/Yath/Options/Run.pm new file mode 100644 index 000000000..b9d422d6b --- /dev/null +++ b/lib2.0/App/Yath/Options/Run.pm @@ -0,0 +1,228 @@ +package App::Yath::Options::Run; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/decode_json/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use List::Util qw/mesh/; + +use Getopt::Yath; + +include_options( + 'App::Yath::Options::Tests', +); + +option_group {group => 'run', category => "Run Options"} => sub { + option links => ( + alt => ['link'], + type => 'List', + + description => "Provide one or more links people can follow to see more about this run.", + + long_examples => [ + " 'https://travis.work/builds/42'", + " 'https://jenkins.work/job/42'", + " 'https://buildbot.work/builders/foo/builds/42'", + ], + ); + + option test_args => ( + type => 'List', + alt => ['test_arg'], + + description => 'Arguments to pass in as @ARGV for all tests that are run. These can be provided easier using the \'::\' argument separator.' + ); + + option input => ( + type => 'Scalar', + + description => 'Input string to be used as standard input for ALL tests. See also: --input-file', + ); + + option input_file => ( + type => 'Scalar', + + description => 'Use the specified file as standard input to ALL tests', + + trigger => sub { + my %params = @_; + return unless $params{action} eq 'set'; + + my ($file) = @{$params{val}}; + die "Input file not found: $file\n" unless -f $file; + + my $settings = $params{settings}; + if ($settings->run->input) { + warn "Input file is overriding a --input string.\n"; + $settings->run->field(input => undef); + } + }, + ); + + option dbi_profiling => ( + type => 'Bool', + default => 0, + + description => "Use Test2::Plugin::DBIProfile to collect database profiling data", + + trigger => sub { + my $opt = shift; + my %params = @_; + + return unless $params{action} eq 'set'; + + eval { require Test2::Plugin::DBIProfile; 1 } or die "Could not enable DBI Profiling: $@"; + + my $load_import = $params{settings}->tests->load_import; + + unless ($load_import->{'Test2::Plugin::DBIProfile'}) { + $load_import->{'Test2::Plugin::DBIProfile'} //= []; + push @{$load_import->{'@'}} => 'Test2::Plugin::DBIProfile'; + } + }, + ); + + option author_testing => ( + type => "Bool", + short => 'A', + + set_env_vars => ['AUTHOR_TESTING'], + from_env_vars => ['AUTHOR_TESTING'], + description => 'This will set the AUTHOR_TESTING environment to true', + + trigger => sub { + my $opt = shift; + my %params = @_; + + if ($params{action} eq 'set') { + $params{settings}->tests->env_vars->{AUTHOR_TESTING} = 1; + } + else { + delete $params{settings}->tests->env_vars->{AUTHOR_TESTING}; + } + }, + + ); + + option stream => ( + type => 'Bool', + default => 1, + alt_no => ['TAP'], + + description => "The TAP format is lossy and clunky. Test2::Harness normally uses a newer streaming format to receive test results. There are old/legacy tests where this causes problems, in which case setting --TAP or --no-stream can help.", + ); + + option fields => ( + alt => ['field'], + type => 'List', + short => 'f', + + long_examples => [' name=details', qq[ '{"name":"NAME","details":"DETAILS"]], + short_examples => [' name=details', qq[ '{"name":"NAME","details":"DETAILS"]], + description => "Add custom data to the harness run", + normalize => sub { m/^\s*\{.*\}\s*$/s ? decode_json($_[0]) : {mesh(['name', 'details'], [split /[=]/, $_[0]])} }, + ); + + option run_id => ( + type => 'Scalar', + alt => ['id'], + default => \&gen_uuid, + + description => 'Set a specific run-id. (Default: a UUID)', + ); + + option event_uuids => ( + type => 'Bool', + default => 1, + + description => 'Use Test2::Plugin::UUID inside tests (default: on)', + ); + + option mem_usage => ( + type => 'Bool', + default => 1, + + description => 'Use Test2::Plugin::MemUsage inside tests (default: on)', + ); + + option retry => ( + type => 'Scalar', + short => 'r', + default => 0, + + description => 'Run any jobs that failed a second time. NOTE: --retry=1 means failing tests will be attempted twice!', + ); + + option retry_isolated => ( + type => 'Bool', + alt => ['retry-iso'], + default => 0, + + description => 'If true then any job retries will be done in isolation (as though -j1 was set)', + ); + + option abort_on_bail => ( + type => 'Bool', + default => 1, + description => "Abort all testing if a bail-out is encountered (default: on)", + ); + + option nytprof => ( + type => 'Bool', + description => "Use Devel::NYTProf on tests. This will set addpid=1 for you. This works with or without fork.", + long_examples => [''], + ); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Run - Run options for Yath. + +=head1 DESCRIPTION + +This is where command lines options for a single test run are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/lib2.0/App/Yath/Options/Runner.pm b/lib2.0/App/Yath/Options/Runner.pm new file mode 100644 index 000000000..2d8b994f0 --- /dev/null +++ b/lib2.0/App/Yath/Options/Runner.pm @@ -0,0 +1,72 @@ +package App::Yath::Options::Runner; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/mod2file fqmod/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Getopt::Yath; + +include_options( + 'App::Yath::Options::Tests', +); + +option_group {group => 'runner', category => "Runner Options"} => sub { + option class => ( + name => 'runner', + field => 'class', + type => 'Scalar', + default => 'Test2::Harness::Runner', + + mod_adds_options => 1, + long_examples => [' MyRunner', ' +Test2::Harness::Runner::MyRunner'], + description => 'Specify what Runner subclass to use. Use the "+" prefix to specify a fully qualified namespace, otherwise Test2::Harness::Runner::XXX namespace is assumed.', + + normalize => sub { fqmod('Test2::Harness::Runner', $_[0]) }, + ); + + option dump_depmap => ( + type => 'Bool', + default => 0, + description => "When using staged preload, dump the depmap for each stage as json files", + ); + + option preloads => ( + type => 'List', + alt => ['preload'], + short => 'P', + + description => 'Preload a module before running tests', + ); + + option runner_id => ( + type => 'Scalar', + default => sub { gen_uuid() }, + + description => 'Runner ID (usually a generated uuid)', + ); + + option reloader => ( + type => 'Auto', + alt => ['reload'], + autofill => 'Test2::Harness::Runner::Reloader', + normalize => sub { fqmod('Test2::Harness::Runner::Reloader', $_[0]) }, + + description => "Use a reloader (default Test2::Harness::Runner::Reload) to reload modules in place. This is discouraged as there are too many gotchas", + ); +}; + +option_post_process \&runner_post_process; + +sub runner_post_process { + my ($options, $state) = @_; + + my $settings = $state->{settings}; + my $runner = $settings->runner; + my $tests = $settings->tests; + + warn "WARNING: Combining preload and switches will render preloads useless...\n" + if @{$runner->preloads // []} && @{$tests->switches // []}; +}; diff --git a/lib2.0/App/Yath/Options/Scheduler.pm b/lib2.0/App/Yath/Options/Scheduler.pm new file mode 100644 index 000000000..6301ab183 --- /dev/null +++ b/lib2.0/App/Yath/Options/Scheduler.pm @@ -0,0 +1,150 @@ +package App::Yath::Options::Scheduler; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Getopt::Yath; +include_options( + 'App::Yath::Options::Tests', +); + +option_group {group => 'scheduler', category => 'Scheduler Options'} => sub { + option class => ( + name => 'scheduler', + field => 'class', + type => 'Scalar', + default => 'Test2::Harness::Scheduler', + + mod_adds_options => 1, + long_examples => [' MyScheduler', ' +Test2::Harness::MyScheduler'], + description => 'Specify what Scheduler subclass to use. Use the "+" prefix to specify a fully qualified namespace, otherwise Test2::Harness::Scheduler::XXX namespace is assumed.', + + normalize => sub { fqmod('Test2::Harness::Scheduler', $_[0]) }, + ); + + option shared_jobs_config => ( + type => 'Scalar', + default => '.sharedjobslots.yml', + long_examples => [' .sharedjobslots.yml', ' relative/path/.sharedjobslots.yml', ' /absolute/path/.sharedjobslots.yml'], + description => 'Where to look for a shared slot config file. If a filename with no path is provided yath will search the current and all parent directories for the name.', + ); +}; + +option_post_process \&scheduler_post_process; + +sub scheduler_post_process { + my ($options, $state) = @_; + + my $settings = $state->{settings}; + my $scheduler = $settings->scheduler; + my $tests = $settings->tests; + + warn "Fix shared job slots"; +} + +1; + +__END__ + +sub fix_job_resources { + my ($settings) = @_; + + my $runner = $settings->runner; + + require Test2::Harness::Runner::Resource::SharedJobSlots::Config; + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + + my %found; + for my $r (@{$runner->resources}) { + require(mod2file($r)); + next unless $r->job_limiter; + $found{$r}++; + } + + if ($sconf && !$found{'Test2::Harness::Runner::Resource::SharedJobSlots'}) { + if (delete $found{'Test2::Harness::Runner::Resource::JobCount'}) { + @{$settings->runner->resources} = grep { $_ ne 'Test2::Harness::Runner::Resource::JobCount' } @{$runner->resources}; + } + + if (!keys %found) { + require Test2::Harness::Runner::Resource::SharedJobSlots; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::SharedJobSlots'; + $found{'Test2::Harness::Runner::Resource::SharedJobSlots'}++; + } + } + elsif (!keys %found) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + if ($found{'Test2::Harness::Runner::Resource::SharedJobSlots'} && $sconf) { + $runner->field(job_count => $sconf->default_slots_per_run || $sconf->max_slots_per_run) if $runner && !$runner->job_count; + $runner->field(slots_per_job => $sconf->default_slots_per_job || $sconf->max_slots_per_job) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "Requested job count ($run_slots) exceeds the system shared limit (" . $sconf->max_slots_per_run . ").\n" + if $run_slots > $sconf->max_slots_per_run; + + die "Requested job concurrency ($job_slots) exceeds the system shared limit (" . $sconf->max_slots_per_job . ").\n" + if $job_slots > $sconf->max_slots_per_job; + } + + $runner->field(job_count => 1) if $runner && !$runner->job_count; + $runner->field(slots_per_job => 1) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "The slots_per_job (set to $job_slots) must not be larger than the job_count (set to $run_slots).\n" if $job_slots > $run_slots; +} + + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Scheduler - Scheduler options for Yath. + +=head1 DESCRIPTION + +This is where command line options for the runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Options/Tests.pm b/lib2.0/App/Yath/Options/Tests.pm new file mode 100644 index 000000000..178d22062 --- /dev/null +++ b/lib2.0/App/Yath/Options/Tests.pm @@ -0,0 +1,227 @@ +package App::Yath::Options::Tests; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Util qw/IS_WIN32/; +use File::Spec; +use Getopt::Yath; + +my $DEFAULT_COVER_ARGS = '-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + +option_group {group => 'tests', category => 'Test Options'} => sub { + option env_vars => ( + type => 'Map', + alt => ['env-var'], + short => 'E', + + description => 'Set environment variables', + ); + + option use_fork => ( + type => 'Bool', + alt => ['fork'], + description => "(default: on, except on windows) Normally tests are run by forking, which allows for features like preloading. This will turn off the behavior globally (which is not compatible with preloading). This is slower, it is better to tag misbehaving tests with the '# HARNESS-NO-PRELOAD' comment in their header to disable forking only for those tests.", + from_env_vars => [qw/!T2_NO_FORK T2_HARNESS_FORK !T2_HARNESS_NO_FORK YATH_FORK !YATH_NO_FORK/], + default => sub { + return 0 if IS_WIN32; + return 1; + }, + ); + + option load => ( + type => 'List', + short => 'm', + alt => ['load-module'], + + description => 'Load a module in each test (after fork). The "import" method is not called.', + ); + + option load_import => ( + type => 'Map', + short => 'M', + alt => ['loadim'], + + long_examples => [' Module', ' Module=import_arg1,arg2,...', qq/ '{"Data::Dumper":["Dumper"]}'/], + short_examples => [' Module', ' Module=import_arg1,arg2,...', qq/ '{"Data::Dumper":["Dumper"]}'/], + + description => 'Load a module in each test (after fork). Import is called.', + normalize => sub { $_[0] => [split /,/, $_[1]] }, + + trigger => sub { + my $opt = shift; + my %params = @_; + + return unless $params{action} eq 'set'; + + my $mod = $params{val}->[0]; + push @{$params{ref}->{'@'}} => $mod unless $params{ref}->{$mod}; + }, + ); + + option use_timeout => ( + type => 'Bool', + alt => ['timeout'], + description => "(default: on) Enable/disable timeouts", + default => 1, + ); + + option includes => ( + type => 'List', + name => 'include', + short => 'I', + description => "Add a directory to your include paths", + ); + + option tlib => ( + type => 'Bool', + default => 0, + + description => "(Default: off) Include 't/lib' in your module path", + ); + + option lib => ( + type => 'Bool', + short => 'l', + default => 1, + + description => "(Default: include if it exists) Include 'lib' in your module path", + ); + + option blib => ( + type => 'Bool', + short => 'b', + default => 1, + + description => "(Default: include if it exists) Include 'blib/lib' and 'blib/arch' in your module path", + ); + + option cover => ( + type => 'Auto', + autofill => $DEFAULT_COVER_ARGS, + + from_env_vars => [qw/T2_DEVEL_COVER/], + set_env_vars => [qw/T2_DEVEL_COVER/], + + description => "Use Devel::Cover to calculate test coverage. This disables forking. If no args are specified the following are used: $DEFAULT_COVER_ARGS", + long_examples => ['', "=$DEFAULT_COVER_ARGS"], + ); + + option switches => ( + type => 'List', + alt => ['switch'], + short => 'S', + description => 'Pass the specified switch to perl for each test. This is not compatible with preload.', + ); + + option event_timeout => ( + alt => ['et'], + + type => 'Scalar', + default => 60, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Kill test if no output is received within timeout period. (Default: 60 seconds). Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis. This prevents a hung test from running forever.', + ); + + option post_exit_timeout => ( + alt => ['pet'], + + type => 'Scalar', + default => 15, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Stop waiting post-exit after the timeout period. (Default: 15 seconds) Some tests fork and allow the parent to exit before writing all their output. If Test2::Harness detects an incomplete plan after the test exits it will monitor for more events until the timeout period. Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis.' + ); + + option unsafe_inc => ( + type => 'Bool', + default => 0, + + from_env_vars => [qw/PERL_USE_UNSAFE_INC/], + description => "perl is removing '.' from \@INC as a security concern. This option keeps things from breaking for now.", + ); +}; + +option_post_process \&tests_post_process; + +sub tests_post_process { + my ($options, $state) = @_; + + my $settings = $state->{settings}; + my $tests = $settings->tests; + + push @{$tests->includes} => File::Spec->catdir('t', 'lib') if $tests->tlib; + push @{$tests->includes} => 'lib' if $tests->lib; + if ($tests->blib) { + push @{$tests->includes} => ( + File::Spec->catdir('blib', 'lib'), + File::Spec->catdir('blib', 'arch'), + ); + } + + if ($tests->cover) { + $tests->cover($DEFAULT_COVER_ARGS) if $tests->cover eq '1'; + + $tests->use_fork(0); + $settings->tests->env_vars->{T2_NO_FORK} = 1; + $ENV{T2_NO_FORK} = 1; + + push @{$tests->load_import->{'@'}} => 'Devel::Cover'; + $tests->load_import->{'Devel::Cover'} = [split(/,/, $tests->cover)]; + } +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Runner - Runner options for Yath. + +=head1 DESCRIPTION + +This is where command line options for the runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Options/Yath.pm b/lib2.0/App/Yath/Options/Yath.pm new file mode 100644 index 000000000..67c7a8314 --- /dev/null +++ b/lib2.0/App/Yath/Options/Yath.pm @@ -0,0 +1,157 @@ +package App::Yath::Options::Yath; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/find_libraries mod2file fqmod/; + +use Getopt::Yath; + +option_group {group => 'yath', category => 'Yath Options'} => sub { + option project => ( + type => 'Scalar', + alt => ['project-name'], + description => 'This lets you provide a label for your current project/codebase. This is best used in a .yath.rc file.', + ); + + option 'show-opts' => ( + type => 'Auto', + autofill => 1, + description => 'Exit after showing what yath thinks your options mean', + short_examples => ['', '=group'], + long_examples => ['', '=group'], + ); + + option version => ( + type => 'Bool', + short => 'V', + description => "Exit after showing a helpful usage message", + ); + + option scan_options => ( + type => 'BoolMap', + + clear => sub { {options => 0} }, + pattern => qr/scan-(.+)/, + + description => 'Yath will normally scan plugins for options. Some commands scan other libraries (finders, resources, renderers, etc) for options. You can use this to disable all scanning, or selectively disable/enable some scanning.', + notes => 'This is parsed early in the argument processing sequence, before options that may be earlier in your argument list.', + ); + + option dev_libs => ( + type => 'AutoList', + short => 'D', + name => 'dev-lib', + + autofill => sub { map { clean_path($_) } 'lib', 'blib/lib', 'blib/arch' }, + + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', 'lib', '=lib', 'lib'], + + normalize => \&clean_path, + + trigger => sub { + my $opt = shift; + my %params = @_; + + return unless $params{action} eq 'set'; + + my $ref = $params{ref}; + my $val = $params{val}; + my %seen = map { $_ => 1 } @{$$ref}; + my @new = grep { !$seen{$_}++ } @$val; + + return unless @new; + + warn <<" EOT" for @new; +dev-lib '$_' added to \@INC late, it is possible some yath libraries were already loaded from other paths. +(Maybe you need to move the -D or --dev-lib argument(s) to be earlier in your command line or config file?) + EOT + }, + + notes => 'This is parsed early in the argument processing sequence, before options that may be earlier in your argument list.', + ); + + option help => ( + type => 'Auto', + autofill => 1, + short => 'h', + description => "exit after showing help information", + short_examples => ['', '=Category', '="Category with space"'], + long_examples => ['', '=Category', '="Category with space"'], + ); + + option plugins => ( + type => 'Map', + short => 'p', + alt => ['plugin'], + + description => 'Load a yath plugin.', + mod_adds_options => 1, + + normalize => sub { + my ($class, $args) = @_; + + $class = fqmod('App::Yath::Plugin', $class); + my $file = mod2file($class); + require $file; + + $args = $args ? [split ',', $args] : []; + + return $class => $args; + }, + ); +}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Yath - Core yath options + +=head1 DESCRIPTION + +Core yath command options. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2023 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Plugin.pm b/lib2.0/App/Yath/Plugin.pm new file mode 100644 index 000000000..c5911f395 --- /dev/null +++ b/lib2.0/App/Yath/Plugin.pm @@ -0,0 +1,180 @@ +package App::Yath::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Plugin'; + +# We do not want this defined by default, but it should be documented +#sub handle_event {} +#sub sort_files {} +#sub sort_files_2 {} + +sub finish {} + +sub finalize {} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin - Base class for yath plugins + +=head1 DESCRIPTION + +This is a base class for yath plugins. Note this class also subclasses +L<Test2::Harness::Plugin>. + +This class holds the methods specific to yath, which is the UI layer. +L<Test2::Harness::Plugin> holds the methods specific to L<Test2::Harness> which +is the backend. + +=head1 SYNOPSIS + + package App::Yath::Plugin::MyPlugin; + + use parent 'App::Yath::Plugin'; + + # ... Define methods + + 1; + + +Then to use it at the command line: + + $ yath -pMyPlugin ... + +=head1 NOTE ON INSTANCE VS CLASS + +None of the plugin base classes provide a C<new()> method. By default plugins +are not instantiated and only the plugin package name is passed around. All +methods are then called on the class. + +If you want your plugin to be instantiated as an object you need only define a +C<new()> method. If this method is defined yath will call it and create an +instance. The instance created will then be used when calling all the methods. + +To pass arguments to the constructor you can use +C<yath -pYourPlugin=arg1,arg2,arg3...>. Your plugin can also define options +using L<App::Yath::Options> which will be dropped into the C<$settings> that +get passed around. + +=head1 METHODS + +B<Note:> See L<Test2::Harness::Plugin> for additional method you can implement/override + +=over 4 + +=item $plugin->handle_event($event, $settings) + +Called for every single event that yath sees. Note that this method is not +defined by default for performance reasons, however it will be called if you +define it. + +=item @sorted = $plugin->sort_files_2(settings => $settings, files => \@unsorted) + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::Task::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +If this is present then C<sort_files()> will be ignored. + +=item @sorted = $plugin->sort_files(@unsorted) + +B<DEPRECATED> Use C<sort_files_2()> instead. + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::Task::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +=item $plugin->finish(%args) + +This is what arguments are recieved: + + ( + settings => $settings, # The settings + final_data => $final_data, # See below + pass => $pass ? 1 : 0, # Always a 0 or 1 + tests_seen => $self->{+TESTS_SEEN} // 0, # Integer 0 or greater + asserts_seen => $self->{+ASSERTS_SEEN} // 0, # Integer 0 or greater + ) + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=item $plugin->finalize($settings) + +This is called as late as possible before exit. This is mainly useful for +outputting messages such as "Extra log file written to ..." which are best put +at the end of output. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/App/Yath/Renderer.pm b/lib2.0/App/Yath/Renderer.pm new file mode 100644 index 000000000..11767a2e8 --- /dev/null +++ b/lib2.0/App/Yath/Renderer.pm @@ -0,0 +1,114 @@ +package App::Yath::Renderer; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + <color + <hide_runner_output + <progress + <quiet + <show_times + <term_width + <truncate_runner_output + <verbose + <wrap + <interactive + <is_persistent + <show_job_end + <show_job_info + <show_job_launch + <show_run_info +}; + +sub init {} + +sub render_event { croak "$_[0] forgot to override 'render_event()'" } + +sub start { } +sub step { } +sub finish { } + +sub settings { shift->state->settings } + +sub run { + my $self = shift; + my %params = @_; + + my $aggregators = $params{aggregators}; + + delete $aggregators->{runner} if $self->hide_runner_output; + + my $harness = $self->state; + + $self->start; + + my (%handles, %done); + my $sig; + + $SIG{INT} = sub { $sig = 'INT' }; + $SIG{TERM} = sub { $sig = 'TERM' }; + + my $seen_warn = 0; + while (1) { + my $not_done = 0; + my $events = 0; + + warn "Fix this to also read from job outputs in verbose mode" unless $seen_warn; + warn "Fix this to also read from job outputs for failed jobs in verbose+quiet mode" unless $seen_warn; + $seen_warn ||= 1; + + for my $name (keys %$aggregators) { + last if $sig; + my $id = $aggregators->{$name}; + next if $done{$id}; + + $not_done++; + + unless ($handles{$id}) { + my $agg = $harness->shared_get(aggregator => $id) or next; + my $file = $agg->output_file or next; + next unless -f $file; + + if ($name eq 'runner' && $self->truncate_runner_output) { + $handles{$id} = Test2::Harness::Util::File::JSONL->new(name => $file, tail => 0); + } + else { + $handles{$id} = Test2::Harness::Util::File::JSONL->new(name => $file); + } + } + + my $reader = $handles{$id} or next; + my @events = $reader->poll(max => 100); + for my $event (@events) { + last if $sig; + $events++; + + unless ($event) { + $done{$id} = 1; + next; + } + + $self->render_event($event); + } + } + + next if $events; + last unless $not_done; + + last if $sig; + + $self->step(); + sleep 0.2; + } + + $self->finish(); + + return 0; +} + +1; diff --git a/lib2.0/App/Yath/Renderer/Default.pm b/lib2.0/App/Yath/Renderer/Default.pm new file mode 100644 index 000000000..4b21a4dfe --- /dev/null +++ b/lib2.0/App/Yath/Renderer/Default.pm @@ -0,0 +1,165 @@ +package App::Yath::Renderer::Default; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Harness::Util qw/mod2file/; +use Storable qw/dclone/; + +use parent 'App::Yath::Renderer'; +use Test2::Harness::Util::HashBase qw{ + <formatter + <io <io_err + <do_step +}; + +sub proc_name { 'yath-renderer' } + +sub start {} + +sub step { + my $self = shift; + return unless $self->{+DO_STEP}; + $self->{+FORMATTER}->step; +} + +sub finish { + my $self = shift; + $self->{+FORMATTER}->finalize(); +} + +sub init { + my $self = shift; + + my $f_class = $self->formatter // 'Test2::Formatter::Test2'; + die "Invalid formatter class: $f_class" if ref($f_class); + + my $f_file = mod2file($f_class); + require $f_file; + + my $io = $self->{+IO} || $self->{output} || \*STDOUT; + unless (ref $io) { + open(my $fh, '>', $io) or die "Could not open file '$io' for writing: $!"; + $self->{+IO} = $fh; + } + + my $io_err = $self->{+IO_ERR} || $self->{output} || \*STDERR; + unless (ref $io_err) { + open(my $fh, '>', $io_err) or die "Could not open file '$io_err' for writing: $!"; + $self->{+IO_ERR} = $fh; + } + + $self->{+INTERACTIVE} //= 1 if $ENV{YATH_INTERACTIVE}; + + $self->{+FORMATTER} = $f_class->new( + io => $io, + handles => [$io, $io_err, $io], + color => $self->color, + interactive => $self->interactive, + is_persistent => $self->is_persistent, + no_wrap => $self->wrap ? 0 : 1, + progress => $self->progress, + verbose => $self->verbose, + ); + + $self->{+DO_STEP} = $self->{+FORMATTER}->can('step') ? 1 : 0; + + $self->{+SHOW_JOB_END} = 1 unless defined $self->{+SHOW_JOB_END}; +} + +sub render_event { + my $self = shift; + my ($event) = @_; + + # We modify the event, which would be bad if there were multiple renderers, + # so we deep clone it. + $event = dclone($event); + + my $f = $event->{facet_data}; # Optimization + + $f->{harness} = {%$event}; + delete $f->{harness}->{facet_data}; + + if ($self->{+SHOW_RUN_INFO} && $f->{harness_run}) { + my $run = $f->{harness_run}; + + push @{$f->{info}} => { + tag => 'RUN INFO', + details => encode_pretty_json($run), + }; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + + $f->{harness}->{job_id} ||= $job->{job_id}; + + if ($self->{+SHOW_JOB_LAUNCH}) { + push @{$f->{info}} => { + tag => $f->{harness_job_launch}->{retry} ? 'RETRY' : 'LAUNCH', + debug => 0, + important => 1, + details => File::Spec->abs2rel($job->{file}), + }; + } + + if ($self->{+SHOW_JOB_INFO}) { + push @{$f->{info}} => { + tag => 'JOB INFO', + details => encode_pretty_json($job), + }; + } + } + + if ($f->{harness_job_end}) { + my $job = $f->{harness_job}; + my $skip = $f->{harness_job_end}->{skip}; + my $fail = $f->{harness_job_end}->{fail}; + my $file = $f->{harness_job_end}->{file}; + my $retry = $f->{harness_job_end}->{retry}; + + my $job_id = $f->{harness}->{job_id} ||= $job->{job_id}; + + # Make the times important if they were requested + if ($self->show_times && $f->{info}) { + for my $info (@{$f->{info}}) { + next unless $info->{tag} eq 'TIME'; + $info->{important} = 1; + } + } + + if ($self->{+SHOW_JOB_END}) { + my $name = File::Spec->abs2rel($file); + $name .= " - $skip" if $skip; + + my $tag = 'PASSED'; + $tag = 'SKIPPED' if $skip; + $tag = 'FAILED' if $fail; + $tag = 'TO RETRY' if $retry; + + unshift @{$f->{info}} => { + tag => $tag, + debug => $fail, + important => 1, + details => $name, + }; + } + } + + my $num = $f->{assert} && $f->{assert}->{number} ? $f->{assert}->{number} : undef; + + $self->{+FORMATTER}->write($event, $num, $f); +} + +sub TO_JSON { + my $self = shift; + + my $data = $self->SUPER::TO_JSON(); + delete $data->{+FORMATTER}; + + return $data; +} + +1; diff --git a/lib2.0/App/Yath/Renderer/JSON.pm b/lib2.0/App/Yath/Renderer/JSON.pm new file mode 100644 index 000000000..6b489d343 --- /dev/null +++ b/lib2.0/App/Yath/Renderer/JSON.pm @@ -0,0 +1,34 @@ +package App::Yath::Renderer::JSON; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json encode_json/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Renderer'; +use Test2::Harness::Util::HashBase qw{<outfile <outfh <pretty}; + +sub init { + my $self = shift; + + $self->{+OUTFH} //= $self->{+OUTFILE} ? open_file($self->{+OUTFILE}, '>') : \*STDOUT; +} + +sub start { print {$_[0]->{+OUTFH}} "[\n" } + +sub render_event { + my $self = shift; + my ($event) = @_; + + chomp(my $json = $self->{+PRETTY} ? encode_pretty_json($event) : encode_json($event)); + $json =~ s/^/ /mg; + print {$self->{+OUTFH}} $json . ",\n"; +} + +sub step { } + +sub finish { print {$_[0]->{+OUTFH}} " null\n]\n" } + +1; diff --git a/lib2.0/App/Yath/Renderer/JSONL.pm b/lib2.0/App/Yath/Renderer/JSONL.pm new file mode 100644 index 000000000..e39061d68 --- /dev/null +++ b/lib2.0/App/Yath/Renderer/JSONL.pm @@ -0,0 +1,40 @@ +package App::Yath::Renderer::JSONL; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json encode_json/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Renderer'; +use Test2::Harness::Util::HashBase qw{<outfile <outfh <pretty}; + +sub init { + my $self = shift; + + $self->{+OUTFH} //= $self->{+OUTFILE} ? open_file($self->{+OUTFILE}, '>') : \*STDOUT; +} + +sub render_event { + my $self = shift; + my ($event) = @_; + + chomp(my $json = $self->{+PRETTY} ? encode_pretty_json($event) : encode_json($event)); + print {$self->{+OUTFH}} $json . "\n"; +} + +sub step { } + +sub finish { print {$_[0]->{+OUTFH}} "null\n" } + +sub TO_JSON { + my $self = shift; + + my $data = $self->SUPER::TO_JSON(); + delete $data->{+OUTFH}; + + return $data; +} + +1; diff --git a/lib2.0/App/Yath/Resource.pm b/lib2.0/App/Yath/Resource.pm new file mode 100644 index 000000000..7a850ffe1 --- /dev/null +++ b/lib2.0/App/Yath/Resource.pm @@ -0,0 +1,30 @@ +package App::Yath::Resource; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak cluck/; +use Getopt::Yath; + +use parent 'Test2::Harness::Resource'; +use Test2::Harness::Util::HashBase qw{}; + +sub is_job_limiter { 0 } +sub applies_to_all_tests { 0 } +sub applies_to_test { 0 } +sub available { 0 } +sub available_for_test { 0 } +sub allocate_for_test { croak "Not Implemented" } +sub release_for_test { croak "Not Implemented" } + +sub args_from_settings { + my $class = shift; + my ($settings) = @_; + + cluck "Not Implemented"; + + return (); +} + +1; diff --git a/lib2.0/App/Yath/Resource/Jobs.pm b/lib2.0/App/Yath/Resource/Jobs.pm new file mode 100644 index 000000000..b4e7fed14 --- /dev/null +++ b/lib2.0/App/Yath/Resource/Jobs.pm @@ -0,0 +1,118 @@ +package App::Yath::Resource::Jobs; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Getopt::Yath; +use List::Util qw/sum0/; + +use parent 'App::Yath::Resource'; +use Test2::Harness::Util::HashBase qw{<job_count <slots_per_job <in_use}; + +include_options( + 'App::Yath::Options::Tests', +); + +option_group {group => 'resource', category => 'Resource Options'} => sub { + option job_count => ( + type => 'Scalar', + short => 'j', + alt => ['jobs'], + + description => 'Set the number of concurrent jobs to run. Add a :# if you also wish to designate multiple slots per test. 8:2 means 8 slots, but each test gets 2 slots, so 4 tests run concurrently. Tests can find their concurrency assignemnt in the "T2_HARNESS_MY_JOB_CONCURRENCY" environment variable.', + from_env_vars => [qw/YATH_JOB_COUNT T2_HARNESS_JOB_COUNT HARNESS_JOB_COUNT/], + clear_env_vars => [qw/YATH_JOB_COUNT T2_HARNESS_JOB_COUNT HARNESS_JOB_COUNT/], + long_examples => [' 4', ' 8:2'], + short_examples => ['4', '8:2'], + ); + + option slots_per_job => ( + type => 'Scalar', + short => 'x', + description => "This sets the number of slots each job will use (default 1). This is normally set by the ':#' in '-j#:#'.", + from_env_vars => ['T2_HARNESS_JOB_CONCURRENCY'], + clear_env_vars => ['T2_HARNESS_JOB_CONCURRENCY'], + long_examples => [' 2'], + short_examples => ['2'], + ); +}; + +option_post_process \&jobs_post_process; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + $self->{+JOB_COUNT} //= 1; + $self->{+IN_USE} //= {}; +} + +sub jobs_post_process { + my ($options, $state) = @_; + + my $settings = $state->{settings}; + my $resource = $settings->resource; + my $tests = $settings->tests; + + return unless $resource->job_count; + + if ($resource->job_count =~ /:/) { + my ($job_count, $per_job) = split ':', $resource->job_count, 2; + $resource->job_count($job_count); + $resource->slots_per_job($per_job); + } + + $tests->env_vars->{T2_HARNESS_MY_JOB_COUNT} = $resource->job_count; + $tests->env_vars->{T2_HARNESS_MY_MAX_JOB_CONCURRENCY} = $resource->slots_per_job; +} + +sub args_from_settings { + my $class = shift; + my ($settings) = @_; + + return ( + job_count => $settings->resource->job_count, + slots_per_job => $settings->resource->slots_per_job, + ); +} + +sub is_job_limiter { 1 } +sub applies_to_test { 1 } +sub applies_to_all_tests { 1 } + +sub available { + my $self = shift; + + my $in_use = sum0(values %{$self->{+IN_USE}}); + my $free = $self->job_count - $in_use; + return $free if $free > 0; + return 0; +} + +sub available_for_test { + my $self = shift; + my ($test) = @_; + + my $free = $self->available or return 0; + my $use = 1; warn "fixme"; #$test->job_slots($free); + return $use; +} + +sub allocate_for_test { + my $self = shift; + my ($test, $count) = @_; + + $self->transaction(w => sub { $self->{+IN_USE}->{$test->resource_id} = $count }); +} + +sub release_for_test { + my $self = shift; + my ($test) = @_; + + $self->transaction(w => sub { delete $self->{+IN_USE}->{$test->resource_id} }); +} + +1; diff --git a/lib2.0/Getopt/Yath.pm b/lib2.0/Getopt/Yath.pm new file mode 100644 index 000000000..b6aa2c3fe --- /dev/null +++ b/lib2.0/Getopt/Yath.pm @@ -0,0 +1,788 @@ +package Getopt::Yath; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use Test2::Harness::Util qw/mod2file/; + +use Getopt::Yath::Instance; +use Getopt::Yath::Option; + +sub import { + my $class = shift; + my %params = @_; + + my $caller = caller(); + + my $inst_class = $params{inst_class} // 'Getopt::Yath::Instance'; + + my $instance = $inst_class->new(class => $class); + $instance->include($class->options) if $params{inherit} && $class->can('options'); + + my %export; + my @common; + $export{options} = sub { $instance }; + + $export{option} = sub { + my $title = shift; + my $option = Getopt::Yath::Option->create(trace => [caller()], title => $title, @common ? (%{$common[-1]}) : (), @_); + $instance->_option($option); + }; + + $export{include_options} = sub { + for my $module (@_) { + my $file = mod2file($module); + require $file unless $INC{$file}; + + croak "Module '$module' does not have an 'options' method" + unless $module->can('options'); + + $instance->include($module->options); + } + }; + + $export{option_post_process} = sub { + my $cb = pop; + my $weight = shift // 0; + my ($applicable) = @_; + + $applicable //= $common[-1]->{applicable} if @common; + + croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE'; + + $instance->_post([caller()], $weight, $applicable, $cb); + }; + + $export{option_group} = sub { + my ($set, $sub) = @_; + + my $common = {@common ? (%{$common[-1]}) : (), %$set}; + + $common->{module} = caller unless $common->{no_module}; + + push @common => $common; + my $ok = eval { $sub->(); 1 }; + my $err = $@; + pop @common; + + die $err unless $ok; + }; + + $export{parse_options} = sub { $instance->process_args(@_) }; + + $export{category_sort_map} = sub { $instance->set_category_sort_map(@_) }; + + for my $name (keys %export) { + no strict 'refs'; + croak "$caller already has an '$name' method" + if defined(&{"${caller}\::${name}"}); + + *{"${caller}\::${name}"} = $export{$name}; + } + + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Getopt::Yath - Option processing yath style. + +=head1 DESCRIPTION + +This is the internal getopt processor yath uses. It should work perfectly fine +outside of yath as well. + +=head1 SYNOPSIS + +=head2 DEFINING OPTIONS + + package My::Package; + use Getopt::Yath; + + # Include options from other modules that use Getopt::Yath + include_options( + 'Some::Options::Package', + ..., + ); + + # an option group is basically a way to specify common parameters for all + # options defined in the codeblock. + option_group {category => 'Human readable category', group => 'settings_group'} => sub { + + # In addition to the fields specified here, all the fields from the + # 'option_group' above are included: + option verbose => ( + type => 'Bool', # This is a boolean type, it does not take an argument + + # Optional fields + short => 'v', # Allow -v in addition to --verbose + default => 0, # What value to use if none is specified (booleans default to 0 anyway) + from_env_vars => ['VERBOSE'], # If the $VERBOSE environment variable is set, this will be set to true. + set_env_vars => ['VERBOSE'], # If this is set to true it will also set the $VERBOSE environment variable + + description => "This turns on verbose output", + ); + + option username => ( + type => 'Scalar', # Scalar type, requires an argument + + # Optional + short => 'U', # Allow: -U Bob + alt => ['user', 'uname'], # Allow: --user Bob, --uname Bob + from_env_vars => ['USER'], # Get the value from the $USER env var if it is not provided. + default => sub { "bob" . rand(100) }, # If none is specified, and the env var is empty, generate a default. + + description => "This sets your username", + ); + + # Other options + ... + }; + +=head2 PARSING OPTIONS + + my $parsed = parse_options( + ['-v', '--user', 'fred', 'not_an_opt', '--', '--will-not-process'], # Normally you might pass in \@ARGV + skip_non_opts => 1, # Skip non-opts, that is any argument that does not start with a '-' it will just skip. + stops => ['--'], # Stop processing + no_set_env => 1, # Do not actually change %ENV + groups => { ':{' => '}:' }, # Arguemnts between the :{ and }: will be captured into an arrayref, they can be used as option values, or stand-alone + ); + +The C<$parsed> structure: + + $parsed = { + 'cleared' => {}, # Options that were cleared with --no-opt + 'skipped' => ['not_an_opt'], # Skipped non options + 'settings' => { # Blessed as Getopt::Yath::Settings + 'settings_group' => { # Blessed as Getopt::Yath::Settings::Group + 'verbose' => 1, # The option and its value + 'username' => 'fred', # Another option and value + }, + }, + 'stop' => '--', # We stopped at '--', if there was no '--' this would be undef + 'remains' => ['--will-not-process'], # Stuff after the '--' that we did not process + 'modules' => {'My::Package' => 2}, # Any module that provided options that were seen will be listed + 'env' => {'VERBOSE' => 1} # Environment variabvles that would have been set if not for 'no_set_env' + }; + +=head2 GENERATING COMMAND LINE HELP OUTPUT: + + sub help { + print options()->docs('cli'); + } + + help(); + +Produces: + + Human readable category + --username ARG, --username=ARG, --user ARG, --user=ARG, --uname ARG + --uname=ARG, -U ARG, -U=ARG, --no-username + This sets your username + + Can also be set with the following environment variables: USER + + --verbose, -v, --no-verbose + This turns on verbose output + + Can also be set with the following environment variables: VERBOSE + + The following environment variables will be set after arguments are processed: VERBOSE + +=head2 GENERATING POD: + + sub pod { + print options()->docs('pod', head => 2); # The '2' specifies what heading level to use + } + + pod(); + +Produces: + + =head2 Human readable category + + =over 4 + + =item --username ARG + + =item --username=ARG + + =item --user ARG + + =item --user=ARG + + =item --uname ARG + + =item --uname=ARG + + =item -U ARG + + =item -U=ARG + + =item --no-username + + This sets your username + + Can also be set with the following environment variables: C<USER> + + + =item --verbose + + =item -v + + =item --no-verbose + + This turns on verbose output + + Can also be set with the following environment variables: C<VERBOSE> + + The following environment variables will be set after arguments are processed: C<VERBOSE> + + + =back + +=head1 EXPORTS + +=over 4 + +=item $opts = options() + +This will return an L<Getopt::Yath::Instance> object. This object holds all the +defined options, and does all the real work under the hood. + +=item $parsed = parse_options(\@ARGV) + +=item $parsed = parse_options(\@ARGV, %PARAMS) + +This processes an arrayref of command line arguments into a structure that can +be easily referenced. If there is a problem parsing, such as invalid options in +the array, exceptions will be thrown. + +The C<$parsed> structure will look like this: + + $parsed = { + 'cleared' => {}, # Options that were cleared with --no-opt + 'skipped' => ['not_an_opt'], # Skipped non options + 'settings' => { # Blessed as Getopt::Yath::Settings + 'settings_group' => { # Blessed as Getopt::Yath::Settings::Group + 'verbose' => 1, # The option and its value + 'username' => 'fred', # Another option and value + }, + }, + 'stop' => '--', # We stopped at '--', if there was no '--' this would be undef + 'remains' => ['--will-not-process'], # Stuff after the '--' that we did not process + 'modules' => {'My::Package' => 2}, # Any module that provided options that were seen will be listed + 'env' => {'VERBOSE' => 1} # Environment variabvles that would have been set if not for 'no_set_env' + }; + +Available parameters that effect parsing are: + +=over 4 + +=item stops => \@STOP_LIST + +=item stops => ['--'] + +This is a list of string that if encountered should stop the parsing process. +The string encountered will be put into the C<stop> field of the C<$parsed> +structure. Any unparsed arguments after the stop will be put into the +C<remains> key of the C<$parsed> structure. + +This is mostly useful for supporting the C<--> option. + +=item groups => \%GROUP_BORDERS + +=item groups => { ':{' => '}:' } + +Arguments between the specified start and end tokens will be grouped together into an arrayref. + +=item stop_at_non_opts => BOOL + +This will cause parsing to stop at any non-option. A non-option in this case is +any argument that does not start with a C<->. + +The item stopped at will be placed in the C<stop> field of the C<$parsed> +structure with the remaining arguments placed in the C<remains> field. + +=item skip_non_opts => BOOL + +This will skip any non-option encountered. A non-option is any argument that +does not start with C<->. All skipped items will be placed into the C<skipped> +field of the <$parsed> structure. + +=item skip_invalid_opts => BOOL + +This will skip any invalid option encountered. This includes any argument that +starts with C<-> but is not a valid option. All skipped items will be placed +into the C<skipped> field of the <$parsed> structure. + +=item stop_at_invalid_opts => BOOL + +This will cause parsing to stop at any invalid option. This includes any +argument that starts with C<-> but is not a valid option. + +The item stopped at will be placed in the C<stop> field of the C<$parsed> +structure with the remaining arguments placed in the C<remains> field. + +=item no_set_env => BOOL + +Set this to true to prevent any modifications to C<%ENV>. + +The C<env> key of the C<$parsed> structure will contain the environment +variable changes that would have been made. + +B<Note:> The env key is always included even if C<%ENV> is modified directly. + +=back + +=item include_options('Options::Module::A', 'Options::Module::B', ...) + +This allows you to build libraries of C<Getopt::Yath> options and include them +as needed. Options from the specified libraries will be merged into the current +packages options. + +=item option_group \%fields => sub { ... } + +=item option_group {group => 'my_group'} => sub { option ...; ... } + +Create a group of options with common parameters. + +=item option TITLE => \%SPECIFICATION + +=item option TITLE => (type => '+My::Type', ...) + +=item option TITLE => (type => 'Getopt::Yath::Option::Type', ...) + +=item option TITLE => (type => 'Type', ...) + +This is used to define a single option. You must specify an option NAME and +'type', which must be a valid L<Getopt::Yath::Option> subclass. + +The TILE is used to produce default values for the 'field' and 'name' fields, +both of which can be specidied directly if the automatic values ar enot +sufficient. 'field' gets the value of title with dashes replaced by +underscrores. 'name' gets the value of title with underscores replaced with +dashes. + +Most of the time you can just list the type as the part after the last C<::> in +C<Getopt::Yath::Option::TYPE>. You can also specify +C<Getopt::Yath::Option::TYPE> or C<Getopt::Yath::Option::TYPE::SubType> +directly. However if you need to use a module that is not in the +C<Getopt::Yath::Option::> namespace you will need to prefix the module with a +C<+> to indicate that. + + $export{option_post_process} = sub { + my $cb = pop; + my $weight = shift // 0; + my ($applicable) = @_; + + $applicable //= $common[-1]->{applicable} if @common; + + croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE'; + + $instance->_post([caller()], $weight, $applicable, $cb); + }; + +=back + +=head1 OPTION TYPES AND SPECIFICATIONS + +=head2 REQUIRED WITH NO DEFAULTS + +=over 4 + +=item title + +This is the first argument to C<option()>. It is used to build the default +values for both C<field> and C<name>. + +=item type => 'TypeName' + +=item type => 'Getopt::Yath::Option::TypeName' + +=item type => '+My::Custom::Type' + +This must be a valid L<Getopt::Yath::Option> subclass: + +=item group => "group_name" + +Name of the field to use in the options hash under which the option will be +listed: + +C<< $parsed->{options}->{$group}->{$field_name} = $val >> + +=over 4 + +=item Scalar + +Takes a scalar value. A value is required. Can be used as C<--opt VAL> or +C<--opt=val>. C<--no-opt> can be used to clear the value. + +=item Bool + +Is either on or off. C<--opt> will turn it onn. C<--no-opt> will turn it off. +Default is off unless the C<default> is parameter is provided. + +=item Count + +Is an integer value, default is to start at C<0>. C<--opt> increments the +counter. C<--no-opt> resets the counter. C<--opt=VAL> can be used to specify a +desired count. + +=item List + +Can take multiple values. C<--opt VAL> appends a value to the list. C<--no-opt> +will empty the list. If a C<split_on> parameter is provided then a single use +can set multiple values. For example if C<split_on> is set to C<,> then +C<--opt foo,bar> is provided, then C<foo> and C<bar> will both be added to the +list. + +=item Map + +Expects all values to be C<key=value> pairs and produces a hashref. +C<--opt foo=bar> will set C<$h{foo} = 'bar'>. If a C<split_on> parameter is +provided then a single use can set multiple values. For example if C<split_on> +is set to C<,> then C<--opt foo=bar,baz=bat> is provided, then the result will +have C<$h{foo} = 'bar'; $h{baz} = 'bat'>. + +=item Auto + +This type has an 'autofill' value that is used if no argument is provided to +the parameter, IE C<--opt>. But can also be given a specific value using +C<--opt=val>. It B<DOES NOT> support C<--opt VAL> which will most likely result +in an exception. + +=item AutoList + +This is a combination of 'Auto' and 'List' types. The no-arg form C<--opt> will +add the default values(s) to the list. The C<--opt=VAL> form will add +additional values. + +=item AutoMap + +This is a combination of 'Auto' and 'Map' types. The no-arg form C<--opt> will +add the default key+value pairs to the hash. The C<--opt=KEY=VAL> form will add +additional values. + +=back + +=back + +=head2 REQUIRED WITH SANE DEFAULTS + +=over 4 + +=item field => "field_name" + +Name of the field to use in the group hash for the result of parsing arguments. + +C<< $parsed->{options}->{$group}->{$field_name} = $val >> + +Default is to take the C<title> value and replace any dashes with underscores. + +=item name => "option-name" + +Primary name for the option C<--option-name>. + +Default is to take the C<title> value and replace any underscores with dashes. + +=item trace => [$caller, $file, $line] + +This normally resolves to the place C<option()> was called. You can manually +override it with a custom value, but you should rarely ever need to. + +=item category => "Human Readable documentation category" + +When producing POD or command line documentation, options are put into +"categories" which should be the human readabvle version of the C<group> field. + +Default is "NO CATEGORY - FIX ME". + +=item description => "Explanation of what the option controls" + +Document what the option controls or does. + +Default is 'NO DESCRIPTION - FIX ME'. + +=back + +=head2 OPTIONAL + +=over 4 + +=item short => 's' + +Specify a short flag to use. This is how you provide single-dash single-letter options. + +=over + +=item C<-s> + +If no argument is required this form is available. + +=item C<-s=VAL> + +If an argument is allowed this form is available + +=item C<-sVAL> + +If an argument is allowed, and this form is not directly disabled by the type +(Types can override C<allows_shortval()> to return false to forbid this form. +Currently L<Getopt::Yath::Option::Bool> and L<Getopt::Yath::Option::Count> +disable this form. + +=item C<-sss> + +So far only the L<Getopt::Yath::Option::Count> type makes use of this. It +allows you to add the flag multiple times after a single dash to increment the +count. + +=back + +=item alt => \@LIST + +=item alt => ['alt1', 'alt2'] + +Specify alternate or alias names that can be used to set or toggle a field. + +C<--alt1> C<--alt2 foo> + +=item prefix => "a-prefix" + +Specify a prefix to attach to the name, and to any alternate names. This is mainly useful when specifying an option group: + + option_group {prefix => 'foo'} => sub { + option bar => ( + type => "Bool", + ); + }; + +This would then be used as C<--foo-bar> + +=item module => 'My::Module' + +Specify the module the argument should be associated with. This defaults to the +caller, so usually you do not need to specify it. + +This is mainly used in the case of plugins we only want to load if the option +is used. + +=item no_module => BOOL + +Default is 0. When this is set to true the module name is not used. + +=item applicable => sub { my $options = shift; ... ? 1 : 0 } + +This can be used to dynamically show/hide options. When this returns false the +option will not be available. + +=item initialize => $scalar + +=item initialize => sub { ... } + +Initialize the value to this before any arguments are parsed. This is mainly +used so that L<Getopt::Yath::Option::Map> can start with an empty hash, and +L<Getopt::Yath::Option::List> can be initialized to an empty arrayref. + +This can be a simple scalar (string or number, not a reference), or it may be a +codeblock that returns anything you want. Only 1 item should be returned, extra +values will result in undefined behavior. For a map this should return an empty +hashref, for a list it should return an empty arrayref. + +=item clear => $scalar + +=item clear => sub { ... } + +Similar to C<initialize>, but this is used when clearing the value. For things +like 'Map' this should return a hashref, etc. + +=item default => $scalar + +=item default => sub { ... } + +Set a default to use if no value is provided at the command line. + +This can be a simple scalar (string or number, not a reference), or it may be a +codeblock that returns anything you want. + +Most options will only accept a single default value. +L<Getopt::Yath::Option::Map> and L<Getopt::Yath::Option::List> support a list +of defaults for setting key/value pairs, or adding items to an array. + +These are valid for anything: + + default => 'foo', + default => 123, + default => sub { "hi" } + +This is valid for an L<Getopt::Yath::Option::Map>: + + default => sub { return ('foo' => 'bar') } + +This is valid for a L<Getopt::Yath::Option::List>: + + default => sub { return (1, 2, 3, 4) } + +=item autofill => $scalar + +=item autofill => sub { ... } + +This is used for L<Getopt::Yath::Option::Auto> and similar. This is the value +used if the command line option is provided, but no value is provided with it. + +This can be a simple scalar (string or number, not a reference), or it may be a +codeblock that returns anything you want. + +Most options will only accept a single autofill value. +L<Getopt::Yath::Option::Map> and L<Getopt::Yath::Option::List> support a list +of autofill data for setting key/value pairs, or adding items to an array. + +These are valid for anything: + + autofill => 'foo', + autofill => 123, + autofill => sub { "hi" } + +This is valid for an L<Getopt::Yath::Option::Map>: + + autofill => sub { return ('foo' => 'bar') } + +This is valid for a L<Getopt::Yath::Option::List>: + + autofill => sub { return (1, 2, 3, 4) } + +=item normalize => sub { my ($input) = @_; ...; return $output } + +If you wish to normalize or transform a value then you use this hook. The sub +will get the option and the input value as its arguments. You should return the +new value to set, or the input value if it does not need to change. + +=item trigger => sub { my ($opt, %params) = @_; ... } + +This will be called any time the option is parsed from the command line, or +whenever the command line clears the option. + +B<NOTE:> It will not run when initial, autofill, or default values are set. + +The C<%params> passed into the sub look like this: + + ( + # If this trigger is called because the value is cleared via --no-OPT: + action => 'clear', + val => undef, + + # If a value is set because of --opt being parsed: + action => 'set', + val => [...], + ref => $ref, + state => $state, + options => $self, + settings => $settings, + group => $group, + ); + +Note that val is always passed in as an arrayref. For simple scalar type +options this will only ever have 1 value. For list or map types it may have +multiple values, also note that for such types the trigger will only see the +newly added values in the 'val' arrayref, not the values already included, +which is important as list and map types can be built over several assignments. + +=item from_env_vars => \@LIST + +A list of environment variables that will be used to populate the option's +initial value. These will be checked in order, the first one that is set is the +one that will be used, others will not be checked once a value is found. This +will prevent the default value from being used, but using the option on the +command line will override it. + +B<Note:> that an environment variable can be prefixed with a C<!> to indicate +the value should be boolean-inverted. This means that an option like C<quiet> +can have C<< from_env_vars => ['!VERBOSE'] >> to be set to true when the +VERBOSE env var is false. This also works when setting a variable, so you could +have C<< set_env_vars => ['!VERBOSE']>. + +=item clear_env_vars => \@LIST + +A list of enviornment variables to clear after the options are all populated. +This is useful if you want to use an env var to set an option, but want to make +sure no child proceses see the environemnt variable. + +=item set_env_vars => \@LIST + +A list of environment variables that will be set to the value of this option +(if it is set) when argument processing is complete. + +B<Note:> This is only supported in types that have a single value, maps and +lists are not supported. + +B<Note:> that an environment variable can be prefixed with a C<!> to indicate +the value should be boolean-inverted. This means that an option like C<quiet> +can have C<< from_env_vars => ['!VERBOSE'] >> to be set to true when the +VERBOSE env var is false. This also works when setting a variable, so you could +have C<< set_env_vars => ['!VERBOSE']>. + +=item short_examples => \@LIST + +=item short_examples => ['', 'ARG', '=ARG'] + +=item short_examples => [' ARG', '=ARG'] + +Override the default list of arguments when generating docs. This is used for +the short form (single dash followed by a single letter and then a value +C<-Ilib>, C<-I lib>, C<-I=lib>, C<-v>, C<-vv>, C<-vvv...>) documentation. + +=item long_examples => \@LIST + +=item long_examples => ['', '=ARG'] + +=item long_examples => [' ARG', '=ARG'] + +Override the default list of arguments when generating docs. This is used for +the long form (double-dash and option name and then a value C<--include>, +C<--include=lib>, C<--include lib>) documentation. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Getopt/Yath/Instance.pm b/lib2.0/Getopt/Yath/Instance.pm new file mode 100644 index 000000000..a75af2c33 --- /dev/null +++ b/lib2.0/Getopt/Yath/Instance.pm @@ -0,0 +1,522 @@ +package Getopt::Yath::Instance; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use Test2::Harness::Util qw/mod2file fqmod/; + +use Getopt::Yath::Option; +use Getopt::Yath::Settings; + +use Test2::Harness::Util::HashBase qw{ + +options <included + <posts + <stops + + <class + + +dedup + + +options_map_cache +options_map_cache_key + + category_sort_map +}; + +sub init { + my $self = shift; + + $self->{+OPTIONS} //= []; # List of option instances + $self->{+POSTS} //= {}; # weight => {...} + $self->{+INCLUDED} //= {}; # type => [$inst], + + $self->{+CATEGORY_SORT_MAP} //= {'NO CATEGORY - FIX ME' => 99999}; + + $self->{+DEDUP} = {}; +} + +sub add_option { + my $self = shift; + my $option = Getopt::Yath::Option->create(trace => [caller()], @_); + return $self->_option($option); +} + +sub add_post_process { + my $self = shift; + return $self->_post([caller()], @_); +} + +sub _post { + my $self = shift; + my ($caller, $weight, $applicable, $cb) = @_; + + $weight //= 0; + + return if $self->{+DEDUP}->{$cb}++; + push @{$self->{+POSTS}->{$weight}} => {caller => $caller, weight => $weight, applicable => $applicable, callback => $cb}; +} + +sub include { + my $self = shift; + my ($other) = @_; + + return unless $other; + return if $self->{+DEDUP}->{$other}++; + + push @{$self->included->{ref($other)} //= []} => $other; + + if (my $other_include = $other->included) { + for my $key (keys %{$other_include}) { + push @{$self->included->{$key}} => @{$other_include->{$key} // []}; + } + } + + $self->_option($_) for @{$other->options}; + + for my $set (values %{$other->posts}) { + for my $post (@$set) { + $self->_post(@{$post}{qw/caller weight applicable callback/}); + } + } +} + +sub _option { + my $self = shift; + my ($option) = @_; + + my $options = $self->{+OPTIONS} //= []; # List of option instances + + return if $self->{+DEDUP}->{$option}++; + push @{$options} => $option; +} + +sub options { + my $self = shift; + return [grep { $_->is_applicable($self) } @{$self->{+OPTIONS}}]; +} + +sub option_map { + my $self = shift; + my ($options) = @_; + + $options //= $self->options; + + my $new_key = @$options; + + if (my $old_key = $self->{+OPTIONS_MAP_CACHE_KEY}) { + if ($old_key != $new_key) { + delete $self->{+OPTIONS_MAP_CACHE}; + delete $self->{+OPTIONS_MAP_CACHE_KEY}; + } + + return $self->{+OPTIONS_MAP_CACHE} + if $self->{+OPTIONS_MAP_CACHE}; + } + + my $map = { + custom_match => [], + # --whatever => $option + }; + + for my $option (@$options) { + push @{$map->{custom_match}} => $option->custom_matches + if $option->can('custom_matches'); + + for my $form (keys %{$option->forms}) { + if (my $existing = $map->{$form}) { + croak "Option form '$form' defined twice, first in '" . $existing->trace_string . "' and again in '" . $option->trace_string . "'" if $existing ne $option; + next; + } + + $map->{$form} = $option; + } + } + + $self->{+OPTIONS_MAP_CACHE_KEY} = $new_key; + return $self->{+OPTIONS_MAP_CACHE} = $map; +} + +sub process_args { + my $self = shift; + my ($args, %params) = @_; + + croak "Must provide an argv arrayref" unless $args && ref($args) eq 'ARRAY'; + + my $argv = [@$args]; # Make a copy + + my $settings = $params{settings} // Getopt::Yath::Settings->new({}); + my $stops = $params{stops} // []; + my $groups = $params{groups} // {}; + $stops = { map { ($_ => 1) } @$stops } if $stops && ref($stops) eq 'ARRAY'; + + my $options = $self->options; + + my @skip; + my $state = { + settings => $settings, + skipped => \@skip, + remains => $argv, + env => $params{env} // {}, + cleared => $params{cleared} // {}, + modules => $params{modules} // {}, + stop => undef, + }; + + for my $opt (@$options) { + my $group = $settings->group($opt->group, 1); + my $ref = $group->option_ref($opt->field, 1); + ${$ref} //= $opt->get_initial_value($settings); + $opt->init_settings($state, $settings, $group, $ref); + } + + my $invalid = $params{invalid_opt_callback} // sub { die "'$_[0]' is not a valid option.\n" }; + + my $parse_group; + $parse_group = sub { + my $end = shift; + + my $group = []; + while (@$argv) { + my $arg = shift(@$argv); + return $group if $arg eq $end; + + if (my $nest = $groups->{$arg}) { + $arg = $parse_group->($nest); + } + + push @$group => $arg; + } + + die "Could not find end token '$end' before end of arguments.\n"; + }; + + while (@$argv) { + my $map = $self->option_map($options); + my $base = shift @$argv; + + if (my $end = $groups->{$base}) { + push @skip => $parse_group->($end); + next; + } + + if ($stops->{$base}) { + $state->{stop} = $base; + last; + } + + if ($base !~ m/^-/) { + if ($params{stop_at_non_opts}) { + $state->{stop} = $base; + last; + } + + if ($params{skip_non_opts}) { + push @skip => $base; + next; + } + + $invalid->($base); + } + + my ($first, $set, $arg, $opt, $delta); + + if ($base =~ m/^(-[^-])(=?)(.*)$/) { + my ($other, $eq); + ($first, $set, $other) = ($1, $2, $3); + + if ($opt = $map->{$first}) { + if ($opt->allows_shortval && ($set || $other)) { + $set = 1; + $arg = $other; + } + elsif ($set) { + $arg = $other; + } + else { + unshift @$argv => "-$other" if $other; + } + } + } + else { + ($first, $set, $arg) = split(/(=)/, $base, 2); + $opt = $map->{$first}; + } + + unless ($opt) { + if (my $list = $map->{custom_match}) { + for my $match (@$list) { + ($opt, $delta, $arg) = $match->($base, $state); + next unless $opt; + $set = 1; + last; + } + } + } + + die "Use of 'arg=val' form without a value is not valid in option '$base'.\n" + if $set && !defined($arg); + + unless ($opt) { + if ($params{skip_invalid_opts}) { + push @skip => $base; + next; + } + + if ($params{stop_at_invalid_opts}) { + $state->{stop} = $base; + last; + } + + $invalid->($base); + } + + die "Use of 'arg=val' form is not allowed in option '$base'. Arguments are not allowed for this option type.\n" + if $set && !$opt->allows_arg; + + $delta //= $opt->forms->{$first}; + + $state->{modules}->{$opt->module}++ unless $opt->no_module; + + my $group_name = $opt->group; + my $field_name = $opt->field; + my $group = $settings->group($group_name, 1); + my $ref = $group->option_ref($field_name, 1); + + if ($delta < 0) { + $opt->clear_field($ref); + $opt->trigger(action => 'clear', ref => $ref, val => undef, state => $state, options => $self, settings => $settings, group => $group); + $state->{cleared}->{$group_name}->{$field_name} = 1; + next unless $set; + } + + delete $state->{cleared}->{$group_name}->{$field_name} if $state->{cleared}->{$group_name}; + + if ($opt->requires_arg && !$set) { + die "No argument provided to '$base'.\n" unless @$argv; + $arg = shift(@$argv); + } + + if ($arg) { + if (my $end = $groups->{$arg}) { + $arg = $parse_group->($end); + } + } + + if (ref($arg) && @$arg > 1 && !$opt->allows_list) { + die "Option '$base' cannot take multiple values, got: [" . join(', ' => @$arg) . "].\n"; + } + + my @val; + if (defined $arg) { + @val = $opt->normalize_value(ref($arg) ? @$arg : $arg); + } + elsif ($opt->allows_autofill) { + @val = $opt->get_autofill_value($settings); + } + else { + @val = $opt->no_arg_value($settings); + } + + if ($opt->mod_adds_options) { + my ($class) = @val; + require(mod2file($class)); + if ($class->can('options')) { + if (my $add = $class->options) { + $options->include($add); + } + } + } + + $opt->trigger(action => 'set', ref => $ref, val => \@val, state => $state, options => $self, settings => $settings, group => $group); + $opt->add_value($ref, @val); + } + + for my $opt (@$options) { + my $group_name = $opt->group; + my $field_name = $opt->field; + my $group = $settings->group($group_name, 1); + my $ref = $group->option_ref($field_name, 1); + + # Do not set the default if the --no-OPT form was used. + next if $state->{cleared} && $state->{cleared}->{$group_name} && $state->{cleared}->{$group_name}->{$field_name}; + next if $opt->is_populated($ref); + $opt->add_value($ref, $opt->get_default_value($settings)); + } + + for my $weight (sort { $a <=> $b } keys %{$self->{+POSTS}}) { + for my $set (@{$self->{+POSTS}->{$weight}}) { + next if $set->{applicable} && !$set->{applicable}->($self); + $set->{callback}->($self, $state); + } + } + + for my $opt (@$options) { + my $group = $settings->group($opt->group, 1); + my $ref = $group->option_ref($opt->field, 1); + + for my $env (@{$opt->clear_env_vars // []}) { + $state->{env}->{$env} = undef; + delete $ENV{$env} unless $params{no_set_env}; + } + + $opt->finalize_settings($state, $settings, $group, $ref); + + next unless $opt->can_set_env; + + my $to_set = $opt->set_env_vars or next; + next unless @$to_set; + + next unless $opt->is_populated($ref); + + for my $name (@$to_set) { + my $env = "$name"; + $env =~ s/^(!)//; + my $neg = $1; + my @val = $opt->get_env_value($env => $ref) or next; + if (@val > 1) { + my $title = $opt->title; + my $trace = $opt->trace // ['', 'unknown', 'n/a']; + die "Option '$title' defined in $trace->[1] line $trace->[2] returned more than one value when get_env_value($env) was called.\n"; + } + + my $setval = $val[0]; + $setval = $setval ? 0 : 1 if $neg; + + $state->{env}->{$env} = $val[0]; + $ENV{$env} = $val[0] unless $params{no_set_env}; + } + } + + return $state; +} + +my %DOC_FORMATS = ( + 'cli' => [ + 'cli_docs', # Method to call on opt + "\n", # how to join lines + sub { require Getopt::Yath::Term; Getopt::Yath::Term::color() ? "\n" . Term::ANSIColor::color('bold underline white') . $_[1] . Term::ANSIColor::color('reset') : "\n$_[1]" }, # how to render the category + sub { $_[0] =~ s/^/ /mg; "$_[0]\n" }, # transform the value from the opt + sub { }, # add this at the end + ], + 'pod' => [ + 'pod_docs', # Method to call on opt + "\n\n", # how to join lines + sub { ($_[0] ? ("=back") : (), "=head$_[2] $_[1]", "=over 4") }, # how to render the category + sub { $_[0] }, # transform the value from the opt + sub { $_[0] ? ("=back\n") : () }, # add this at the end + ], +); + +sub docs { + my $self = shift; + my ($format, %params) = @_; + + my $opts = $self->options; + + $format //= "UNDEFINED"; + my $fset = $DOC_FORMATS{$format} or croak "Invalid documentation format '$format'"; + my ($fmeth, $join, $fcat, $ftrans, $fend) = @$fset; + + return unless $opts; + return unless @$opts; + + my @render = @$opts; + + @render = grep { $_->category eq $params{category} } @render if $params{category}; + + return "\n\n!! Invalid option category: $params{category} !!" + unless @render; + + @render = sort { $self->_doc_sort_ops($a, $b) } @render; + + my @out; + + my $cat; + for my $opt (@render) { + if (!$cat || $opt->category ne $cat) { + push @out => $fcat->($cat, $opt->category, $params{head}); + $cat = $opt->category; + } + + my $help = $opt->$fmeth(%params); + push @out => $ftrans->($help); + } + + push @out => $fend->($cat); + s/[ \t]+$//gm for @out; + + return join $join => @out; +} + +sub _doc_sort_ops { + my $self = shift; + my ($a, $b) = @_; + + my $map = $self->{+CATEGORY_SORT_MAP}; + my $aw = $map->{$a->category} || 0; + my $bw = $map->{$b->category} || 0; + + my $ret = $aw <=> $bw; + $ret ||= $a->category cmp $b->category; + $ret ||= ($a->prefix || '') cmp ($b->prefix || ''); + $ret ||= $a->name cmp $b->name; + + return $ret; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Getopt::Yath::Instance - An instance of options. + +=head1 DESCRIPTION + +This does the real work for L<Getopt::Yath> under the hood. It is probably +better not to use this directly. + +=head1 SYNOPSIS + +Do not use this directly. The user interface you should be looking at is +L<Getopt::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/lib2.0/Getopt/Yath/Option.pm b/lib2.0/Getopt/Yath/Option.pm new file mode 100644 index 000000000..2edaa9f40 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option.pm @@ -0,0 +1,592 @@ +package Getopt::Yath::Option; +use strict; +use warnings; + +use Carp qw/croak/; + +use Test2::Harness::Util qw/mod2file fqmod/; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + <title + <field <name <short <alt <alt_no + + <group + <prefix + <trace + + <module <no_module + + <applicable + <default <autofill <initialize <clear + <normalize + +trigger + + <from_env_vars + <clear_env_vars + <set_env_vars + + <category + + <description + +short_examples + +long_examples + + +forms + + <mod_adds_options + + <notes +}; + +sub requires_arg { croak "'$_[0]' does not define requires_arg()" } +sub add_value { croak "'$_[0]' does not define add_value()" } +sub is_populated { croak "'$_[0]' does not define is_populated()" } +sub no_arg_value { croak "'$_[0]' does not define no_arg_value()" } +sub get_env_value { croak "'$_[0]' does not define get_env_value()" } + +sub can_set_env { 0 } +sub requires_autofill { 0 } + +sub allows_shortval { $_[0]->allows_arg } +sub allows_default { 0 } + +sub allows_list { 0 } + +sub allows_arg { $_[0]->requires_arg } +sub allows_autofill { $_[0]->requires_autofill } + +sub get_autofill_value { shift->_get___value(AUTOFILL(), @_) } +sub get_default_value { shift->_get___value(DEFAULT(), @_) } + +sub init_settings { } +sub finalize_settings { } + +sub create { + my $class = shift; + my %params = @_; + + croak "create() cannot be called on an option subclass" unless $class eq __PACKAGE__; + + my $type = delete $params{type} or croak "No 'type' specified"; + + my $new_class = fqmod(__PACKAGE__, $type); + require(mod2file($new_class)); + return $new_class->new(%params); +} + +sub get_initial_value { + my $self = shift; + + my $env = $self->from_env_vars; + for my $name (@{$env || []}) { + my $env = "$name"; + $env =~ s/^(!)//; + my $neg = $1; + + next unless exists $ENV{$env}; + return $ENV{$env} unless $neg; + return $ENV{$env} ? 0 : 1; + } + + return $self->_get___value(INITIALIZE(), @_); +} + +sub get_clear_value { + my $self = shift; + + return $self->_get___value(CLEAR(), @_); +} + +sub _get___value { + my $self = shift; + my ($field, @args) = @_; + return unless exists $self->{$field}; + my $val = $self->{$field}; # May be undef, that is fine if specified. + return $val unless ref($val); + croak "'$field' values must either be simple scalars (not references) or a code ref that returns the '$field' value" + unless ref($val) eq 'CODE'; + return $self->$val(@args); +} + +sub normalize_value { + my $self = shift; + my (@input) = @_; + + my $cb = $self->{+NORMALIZE} or return @input; + return $cb->(@input); +} + +sub trigger { + my $self = shift; + my $cb = $self->{+TRIGGER} or return; + $self->$cb(@_); +} + +sub clear_field { + my $self = shift; + my ($ref) = @_; + return $$ref = $self->get_clear_value(); +} + +sub is_applicable { + my $self = shift; + my ($options) = @_; + my $cb = $self->{+APPLICABLE} or return 1; + return $self->$cb($options); +} + +sub long_args { + my $self = shift; + + return ($self->{+NAME}, @{$self->{+ALT} || []}); +} + +sub trace_string { + my $self = shift; + my $trace = $self->{+TRACE} or return "[UNKNOWN]"; + return "$trace->[1] line $trace->[2]"; +} + +sub long_examples { + my $self = shift; + return @{$self->{+LONG_EXAMPLES}} if $self->{+LONG_EXAMPLES}; + return @{$self->default_long_examples(@_)}; +} + +sub short_examples { + my $self = shift; + return @{$self->{+SHORT_EXAMPLES}} if $self->{+SHORT_EXAMPLES}; + return @{$self->default_short_examples(@_)}; +} + +sub init { + my $self = shift; + + croak "A trace is required" + unless $self->{+TRACE}; + + croak "You must provide either 'module' (a module name for dynamic loading) or set 'no_module'" + unless $self->{+MODULE} || $self->{+NO_MODULE}; + + croak "You must specify 'title' or both 'field' and 'name'" + unless $self->{+TITLE} || ($self->{+FIELD} && $self->{+NAME}); + + croak "The 'group' attribute is required" + unless $self->{+GROUP}; + + croak "'set_env_vars' is not supported for this option type" + if $self->{+SET_ENV_VARS} && !$self->can_set_env; + + croak "The 'alt' attribute must be an array-ref" + if $self->{+ALT} && ref($self->{+ALT}) ne 'ARRAY'; + + croak "The 'alt_no' attribute must be an array-ref" + if $self->{+ALT_NO} && ref($self->{+ALT_NO}) ne 'ARRAY'; + + $self->{+MODULE} //= $self->{+TRACE}->[0] unless $self->{+NO_MODULE}; + + if (my $title = $self->{+TITLE}) { + $self->{+FIELD} //= $title; + $self->{+NAME} //= $title; + } + + $self->{+FIELD} =~ s/-/_/g; + $self->{+NAME} =~ s/_/-/g; + + croak "'default' is not allowed (did you mean 'initialize'" . ($self->allows_autofill ? " or 'autofill'" : "") . "?)" + if $self->{+DEFAULT} && !$self->allows_default; + + croak "'autofill' is required" if $self->requires_autofill && !$self->{+AUTOFILL}; + croak "'autofill' is not allowed" if $self->{+AUTOFILL} && !$self->allows_autofill; + + for my $field (DEFAULT(), AUTOFILL(), INITIALIZE()) { + my $val = $self->{$field} or next; + my $ref = ref($val) or next; + croak "'$field' must be a simple scalar, or a coderef, got a '$ref'" if $ref && $ref ne 'CODE'; + } + + for my $field (NORMALIZE(), APPLICABLE(), TRIGGER()) { + my $val = $self->{$field} or next; + my $ref = ref($val) || 'not a ref'; + next if $ref eq 'CODE'; + croak "'$field' must be undef, or a coderef, got '$ref'"; + } + + $self->{+CATEGORY} //= 'NO CATEGORY - FIX ME'; + $self->{+DESCRIPTION} //= 'NO DESCRIPTION - FIX ME'; + + for my $key (sort keys %$self) { + croak "'$key' is not a valid option attribute" unless $self->can(uc($key)); + } + + return $self; +} + +sub forms { + my $self = shift; + return $self->{+FORMS} if $self->{+FORMS}; + + my $forms = $self->{+FORMS} = {}; + + $forms->{'-' . $self->{+SHORT}} = 1 if $self->{+SHORT}; + + $forms->{$_} = 1 for map { "--$_" } @{$self->{+ALT} // []}; + $forms->{$_} = -1 for map { "--no-$_" } @{$self->{+ALT} // []}; + $forms->{$_} = -1 for map { "--$_" } @{$self->{+ALT_NO} // []}; + + my $name = $self->name; + if (my $prefix = $self->prefix) { + $forms->{"--${prefix}-${name}"} = 1; + $forms->{"--no-${prefix}-${name}"} = -1; + } + else { + $forms->{"--${name}"} = 1; + $forms->{"--no-${name}"} = -1; + } + + return $forms; +} + +sub _example_append { + my $self = shift; + my ($params, @prefixes) = @_; + + return unless $self->allows_list; + + my $groups = $params->{groups} // {}; + + my @out; + + for my $prefix (@prefixes) { + for my $group (sort keys %$groups) { + push @out => "${prefix}${group} ARG1 ARG2 ... $groups->{$group}"; + } + } + + return @out; +} + +sub default_long_examples { + my $self = shift; + my %params = @_; + + return [''] unless $self->allows_arg; + + if ($self->requires_arg) { + return [' ARG', '=ARG', $self->_example_append(\%params, ' ', '=')]; + } + + return ['', '=ARG', $self->_example_append(\%params, '=')]; +} + +sub default_short_examples { + my $self = shift; + my %params = @_; + + return [''] unless $self->allows_arg; + + if ($self->requires_arg) { + return ['ARG', ' ARG', '=ARG', $self->_example_append(\%params, '', ' ', '=')] if $self->allows_shortval; + return [' ARG', '=ARG', $self->_example_append(\%params, ' ', '=')]; + } + + return ['', 'ARG', '=ARG', $self->_example_append(\%params, '', '=')] if $self->allows_shortval; + return ['', '=ARG', $self->_example_append(\%params, '=')]; +} + +sub doc_forms { + my $self = shift; + my %params = @_; + + my $name = $self->{+NAME}; + + my @long_examples = $self->long_examples(%params); + my @forms = (map { "--${name}${_}" } @long_examples ); + + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--${alt}${_}" } @long_examples); + } + + if (my $short = $self->{+SHORT}) { + my @short_examples = $self->short_examples(%params); + push @forms => map { "-${short}${_}" } @short_examples; + } + + @forms = sort { + $a =~ m/^(-+)/; + my $al = length($1 // ''); + $b =~ m/^(-+)/; + my $bl = length($1 // ''); + $al <=> $bl || length($a) <=> length($b); + } @forms; + + my @no_forms; + push @no_forms => "--no-${name}"; + push @no_forms => map { "--$_" } @{$self->{+ALT_NO} // []}; + + return \@forms, \@no_forms; +} + +sub cli_docs { + my $self = shift; + my %params = @_; + + my ($forms, $no_forms, $other_forms) = $self->doc_forms(%params); + + require Getopt::Yath::Term; + + my @out; + if (Getopt::Yath::Term::color()) { + @out = ( + Term::ANSIColor::color('underline white') . $self->{+NAME} . Term::ANSIColor::color('reset'), + (map { Term::ANSIColor::color('green') . $_ . Term::ANSIColor::color('reset') } @{$forms // []}), + (map { Term::ANSIColor::color('yellow') . $_ . Term::ANSIColor::color('reset') } @{$no_forms // []}), + (map { Term::ANSIColor::color('cyan') . $_ . Term::ANSIColor::color('reset') } @{$other_forms // []}), + ); + } + else { + my @out = ( + "[$self->{+NAME}]", + @{$forms // []}, + @{$no_forms // []}, + @{$other_forms // []}, + ); + } + + push @out => Getopt::Yath::Term::fit_to_width(" ", $self->{+DESCRIPTION}, " "); + + push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "Can also be set with the following environment variables: " . join(", ", @{$self->{+FROM_ENV_VARS}}), " ") if $self->{+FROM_ENV_VARS}; + push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "The following environment variables will be cleared after arguments are processed: " . join(", ", @{$self->{+CLEAR_ENV_VARS}}), " ") if $self->{+CLEAR_ENV_VARS}; + push @out => "\n" . Getopt::Yath::Term::fit_to_width(" ", "The following environment variables will be set after arguments are processed: " . join(", ", @{$self->{+SET_ENV_VARS}}), " ") if $self->{+SET_ENV_VARS}; + + if (my @notes = $self->notes) { + my %seen; + push @out => map { "\n" . Getopt::Yath::Term::fit_to_width(" ", "Note: $_", " ") } grep { $_ && !$seen{$_}++ } @notes; + } + + return join "\n" => @out; +} + +sub pod_docs { + my $self = shift; + my %params = @_; + + my ($forms, $no_forms, $other_forms) = $self->doc_forms(%params); + + use Data::Dumper; + print Dumper($forms, $no_forms, $other_forms); + my @out = map { "=item $_" } map { @{$_} } grep { $_ } @$forms, @$no_forms, @$other_forms; + + push @out => $self->description; + + push @out => "Can also be set with the following environment variables: " . join(", ", map { "C<$_>" } @{$self->{+FROM_ENV_VARS}}) if $self->{+FROM_ENV_VARS}; + push @out => "The following environment variables will be cleared after arguments are processed: " . join(", ", map { "C<$_>" } @{$self->{+CLEAR_ENV_VARS}}) if $self->{+CLEAR_ENV_VARS}; + push @out => "The following environment variables will be set after arguments are processed: " . join(", ", map { "C<$_>" } @{$self->{+SET_ENV_VARS}}) if $self->{+SET_ENV_VARS}; + + my %seen; + push @out => map { "Note: $_" } grep { $_ && !$seen{$_}++ } $self->notes; + + return join("\n\n" => @out) . "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Getopt::Yath::Option - Base class for options. + +=head1 DESCRIPTION + +This is the base class for option types used in L<Getopt::Yath>. + +=head1 SYNOPSIS + +To create a new type you want to start with this template: + + package Getopt::Yath::Option::MyType; + use strict; + use warnings; + + # Become a subclass + use parent 'Getopt::Yath::Option'; + + # Bring in some useful constants; + use Test2::Harness::Util::HashBase; + + # Must define these: + ####### + + # True if an arg is required + # True means you can do '--flag value' + # Without this you must do '--flag=value' to set a value, otherwise it can + # act like a bool or a counter and not need a value. + sub requires_arg { ... } + + sub add_value { + my $self = shift; + my ($ref, $val) = @_; + + # $ref contains a scalar ref to where the value is stored + # $val is the value being assigned to the option + # Most types can get away with this: + ${$ref} = $val; + } + + sub is_populated { + my $self = shift; + my ($ref) = @_; + + # $$ref contains the slot where the value would be stored if it was set. + # Most types can get away with this: + return defined(${$ref}) ? 1 : 0; + } + + sub no_arg_value { + my $self = shift; + + # This only happens if you do not require an arg, and do not require an + # autofill. Only bool nd count types currently do this. + # This is the value that will be used in such cases. + # If you do not meet the conditions for this to be called you can simply remove this method. + ...; + } + + # May want to define these, otherwise remove them from this file + ####### + + sub notes { ... } # Return a list of notes to include in documentation + sub allows_arg { ... } # True if an arg is allowed. + sub allows_autofill { ... } # True if autofill is allowed + sub allows_default { ... } # True if defaults are allowed + sub requires_autofill { ... } # True if an auto-fill is allowed + + # Change this to true if this option type can set an environment variable + sub can_set_env { 0 } + + # You only need this if you can set an environment variable + get_env_value { + my $self = shift; + my ($envname, $ref) = @_; + + # For simple scalar values this is usually good enough + # This should be the value to assign to environment variables that are + # set by this option. + return $$ref; + } + + sub default_long_examples { + my $self = shift; + + ...; + + return [' ARG', '=ARG']; # If you require an argument + return ['']; # If do not allow arguments + return ['', '=ARG']; # If arguments are optional + } + + sub default_short_examples { + my $self = shift; + + ...; + + return [' ARG', '=ARG']; # If you require an argument + return ['']; # If do not allow arguments + return ['', '=ARG']; # If arguments are optional + } + + # Run right after the initial value for this option is set. Other options + # may not have their initial values yet. + + sub init_settings { + my $self = shift; + my ($state, $settings, $group, $ref) = @_; + + ... + } + + # Run after all the options have been set, parsed, and post-blocks have + # been run. + # This is run before the environment variable for this option has been set, + # but other options may have had theirs set. + sub finalize_settings { + my $self = shift; + my ($state, $settings, $group, $ref) = @_; + + ... + } + + # Probably should not define these, but here for reference. + # Remove these if you do not plan to override them + # The base class implementations work for most types. + ####### + + sub clear_field { ... } # Used to clear the field + sub get_autofill_value { ... } # Used to get the autofill value + sub get_default_value { ... } # Used to get the default value + + 1; + +=head1 EXAMPLES + +See the following modules source for examples: + +=over 4 + +=item L<Getopt::Yath::Option::Scalar> + +=item L<Getopt::Yath::Option::Bool> + +=item L<Getopt::Yath::Option::Count> + +=item L<Getopt::Yath::Option::List> + +=item L<Getopt::Yath::Option::Map> + +=item L<Getopt::Yath::Option::Auto> + +=item L<Getopt::Yath::Option::AutoList> + +=item L<Getopt::Yath::Option::AutoMap> + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/lib2.0/Getopt/Yath/Option/Auto.pm b/lib2.0/Getopt/Yath/Option/Auto.pm new file mode 100644 index 000000000..8dc552ffb --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/Auto.pm @@ -0,0 +1,27 @@ +package Getopt::Yath::Option::Auto; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option::Scalar'; +use Test2::Harness::Util::HashBase; + +sub allows_default { 1 } +sub allows_arg { 1 } +sub requires_arg { 0 } +sub allows_autofill { 1 } +sub requires_autofill { 1 } + +sub can_set_env { 1 } + +sub get_env_value { + my $opt = shift; + my ($var, $ref) = @_; + + return $$ref unless $var =~ m/^!/; + return $ref ? 0 : 1; +} + + +1; diff --git a/lib2.0/Getopt/Yath/Option/AutoList.pm b/lib2.0/Getopt/Yath/Option/AutoList.pm new file mode 100644 index 000000000..70609e722 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/AutoList.pm @@ -0,0 +1,15 @@ +package Getopt::Yath::Option::AutoList; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option::List'; +use Test2::Harness::Util::HashBase; + +sub allows_arg { 1 } +sub requires_arg { 0 } +sub allows_autofill { 1 } +sub requires_autofill { 1 } + +1; diff --git a/lib2.0/Getopt/Yath/Option/AutoMap.pm b/lib2.0/Getopt/Yath/Option/AutoMap.pm new file mode 100644 index 000000000..d3fe03b6d --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/AutoMap.pm @@ -0,0 +1,19 @@ +package Getopt::Yath::Option::AutoMap; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option::Map'; +use Test2::Harness::Util::HashBase; + +sub allows_arg { 1 } +sub requires_arg { 0 } +sub allows_default { 1 } +sub allows_autofill { 1 } +sub requires_autofill { 1 } + +sub default_long_examples { ['', '=key=val'] } +sub default_short_examples { ['', 'key=val', '=key=val'] } + +1; diff --git a/lib2.0/Getopt/Yath/Option/Bool.pm b/lib2.0/Getopt/Yath/Option/Bool.pm new file mode 100644 index 000000000..5e0db0e61 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/Bool.pm @@ -0,0 +1,39 @@ +package Getopt::Yath::Option::Bool; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option'; +use Test2::Harness::Util::HashBase; + +sub allows_shortval { 0 } +sub allows_default { 1 } +sub allows_arg { 0 } +sub requires_arg { 0 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } + +sub no_arg_value { 1 } # --bool + +# undef is not populated, otherwise qw have 1 or 0 +sub is_populated { defined(${$_[1]}) ? 1 : 0 } + +sub add_value { ${$_[1]} = $_[2] } +sub clear_field { ${$_[1]} = 0 } # --no-bool + +# Default to 0 unless otherwise specified +sub get_default_value { shift->SUPER::get_default_value(@_) ? 1 : 0 } + +sub can_set_env { 1 } + +sub get_env_value { + my $opt = shift; + my ($var, $ref) = @_; + + my $b = $$ref ? 1 : 0; + return $b unless $var =~ m/^!/; + return $b ? 0 : 1; +} + +1; diff --git a/lib2.0/Getopt/Yath/Option/BoolMap.pm b/lib2.0/Getopt/Yath/Option/BoolMap.pm new file mode 100644 index 000000000..57c016628 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/BoolMap.pm @@ -0,0 +1,83 @@ +package Getopt::Yath::Option::BoolMap; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use parent 'Getopt::Yath::Option::Map'; +use Test2::Harness::Util::HashBase qw/+pattern +requires_arg +custom_matches/; + +sub allows_list { 1 } +sub allows_default { 1 } +sub allows_arg { 1 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } + +sub notes { (shift->SUPER::notes(), 'Can be specified multiple times') } + +sub requires_arg { $_[0]->{+REQUIRES_ARG} ? 1 : 0 } + +sub init { + my $self = shift; + $self->SUPER::init(@_); + + croak "A 'pattern' is required" unless $self->{+PATTERN}; + + return $self; +} + +sub no_arg_value { $_[0]->field, 1 } + +sub pattern { + my $self = shift; + + my $append = $self->{+PATTERN}; + return qr/^--(no-)?$append$/; +} + +sub default_long_examples { + my $self = shift; + my $out = $self->SUPER::default_long_examples(@_); + push @$out => $self->pattern; + return $out; +} + +sub default_short_examples { + my $self = shift; + my $out = $self->SUPER::default_short_examples(@_); + push @$out => $self->pattern; + return $out; +} + +sub custom_matches { + my $self = shift; + my $pattern = $self->pattern; + + return sub { + my ($input, $state) = @_; + + return $self->{+CUSTOM_MATCHES}->($self, @_) + if $self->{+CUSTOM_MATCHES}; + + return unless $input =~ $pattern; + my ($no, $key) = ($1, $2); + return ($self, 1, [$key => $no ? 0 : 1]); + }; +} + +sub doc_forms { + my $self = shift; + my %params = @_; + + my ($forms, $no_forms) = $self->SUPER::doc_forms(%params); + + my $inner = "" . $self->{+PATTERN}; + $inner =~ s{^\Q(?^:\E}{}; + $inner =~ s{\)$}{}; + + return ($forms, $no_forms, ["/^--(no-)?$inner\$/"]); +} + +1; diff --git a/lib2.0/Getopt/Yath/Option/Count.pm b/lib2.0/Getopt/Yath/Option/Count.pm new file mode 100644 index 000000000..c38ea6453 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/Count.pm @@ -0,0 +1,57 @@ +package Getopt::Yath::Option::Count; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option'; +use Test2::Harness::Util::HashBase; + +sub allows_shortval { 0 } +sub allows_arg { 1 } +sub requires_arg { 0 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } +sub is_populated { 1 } # Always populated + +sub no_arg_value { () } + +sub clear_field { ${$_[1]} = 0 } # --no-count + +# Autofill should be 0 if not specified +sub get_autofill_value { $_[0]->SUPER::get_autofill_value() // 0 } + +sub default_long_examples {my $self = shift; ['', '=COUNT'] } +sub default_short_examples {my $self = shift; ['', $self->short, ($self->short x 2) . '..', '=COUNT'] } + +sub notes { (shift->SUPER::notes(), 'Can be specified multiple times, counter bumps each time it is used.') } + +# --count +# --count=5 +sub add_value { + my $self = shift; + my ($ref, @val) = @_; + + # Explicit value set + return $$ref = $val[0] if @val; + + # Make sure we have a sane start + $$ref //= $self->get_autofill_value; + + # Bump by one + return ${$ref}++; +} + +sub can_set_env { 1 } + +sub get_env_value { + my $opt = shift; + my ($var, $ref) = @_; + + return $$ref unless $var =~ m/^!/; + return $ref ? 0 : 1; +} + +1; diff --git a/lib2.0/Getopt/Yath/Option/List.pm b/lib2.0/Getopt/Yath/Option/List.pm new file mode 100644 index 000000000..4a0ea180e --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/List.pm @@ -0,0 +1,94 @@ +package Getopt::Yath::Option::List; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/decode_json/; + +use parent 'Getopt::Yath::Option'; +use Test2::Harness::Util::HashBase qw/<split_on/; + +sub allows_list { 1 } +sub allows_arg { 1 } +sub requires_arg { 1 } +sub allows_default { 1 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } + +sub notes { (shift->SUPER::notes(), 'Can be specified multiple times') } + +sub is_populated { ${$_[1]} && @{${$_[1]}} } + +sub get_clear_value { + my $self = shift; + return $self->_get___value(CLEAR(), @_) // []; +} + +sub get_initial_value { + my $self = shift; + + my @val; + + my $env = $self->from_env_vars; + for my $name (@{$env || []}) { + push @val => $ENV{$name} if defined $ENV{$name}; + } + + return \@val if @val; + + return $self->_get___value(INITIALIZE()) // []; +} + +sub add_value { + my $self = shift; + my ($ref, @val) = @_; + push @{$$ref} => @val; +} + +sub normalize_value { + my $self = shift; + my (@input) = @_; + + if ($input[0] =~ m/^\s*\[.*\]\s*$/s) { + my $out; + local $@; + unless (eval { local $SIG{__DIE__}; $out = decode_json($input[0]); 1 }) { + my ($err) = split /[\n\r]+/, $@; + $err =~ s{at \Q$INC{'Test2/Harness/Util/JSON.pm'}\E line \d+\..*$}{}; + die "Could not decode JSON string: $err\n====\n$input[0]\n====\n"; + } + return @$out; + } + + my @output; + if (my $on = $self->split_on) { + @output = map { $self->SUPER::normalize_value($_) } map { split($on, $_) } @input; + } + else { + @output = map { $self->SUPER::normalize_value($_) } @input; + } + + return @output; +} + +sub default_long_examples { + my $self = shift; + my %params = @_; + + my $list = $self->SUPER::default_long_examples(%params); + push @$list => (qq{ '["json","list"]'}, qq{='["json","list"]'}); + return $list; +} + +sub default_short_examples { + my $self = shift; + my %params = @_; + + my $list = $self->SUPER::default_long_examples(%params); + push @$list => (qq{ '["json","list"]'}, qq{='["json","list"]'}); + return $list; +} + + +1; diff --git a/lib2.0/Getopt/Yath/Option/Map.pm b/lib2.0/Getopt/Yath/Option/Map.pm new file mode 100644 index 000000000..5df4ef808 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/Map.pm @@ -0,0 +1,129 @@ +package Getopt::Yath::Option::Map; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::JSON qw/decode_json/; + +use parent 'Getopt::Yath::Option'; +use Test2::Harness::Util::HashBase qw/<split_on <key_on/; + +sub allows_list { 1 } +sub allows_default { 1 } +sub allows_arg { 1 } +sub requires_arg { 1 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } + +sub notes { (shift->SUPER::notes(), 'Can be specified multiple times') } + +sub _example_append { + my $self = shift; + my ($params, @prefixes) = @_; + + return unless $self->allows_list; + + my $groups = $params->{groups} // {}; + + my @out; + + for my $prefix (@prefixes) { + for my $group (sort keys %$groups) { + push @out => "${prefix}${group} KEY1 VAL KEY2 ${group} VAL1 VAL2 ... $groups->{$group} ... $groups->{$group}"; + } + } + + return @out; +} + +sub default_long_examples { + my $self = shift; + my %params = @_; + + my @append = $self->_example_append(\%params, ' ', '='); + + return [' key=val', '=key=val', qq[ '{"json":"hash"}'], qq[='{"json":"hash"}'], @append]; +} + +sub default_short_examples { + my $self = shift; + my %params = @_; + + my @append = $self->_example_append(\%params, '', ' ', '='); + + return [' key=val', 'key=value', '=key=val', qq[ '{"json":"hash"}'], qq[='{"json":"hash"}'], @append]; +} + +sub init { + my $self = shift; + + $self->SUPER::init(); + + $self->{+KEY_ON} //= '='; +} + +sub is_populated { ${$_[1]} && keys %{${$_[1]}} } + +sub get_initial_value { + my $self = shift; + + my %val; + + my $env = $self->from_env_vars; + for my $name (@{$env || []}) { + $val{$name} = $ENV{$name} if defined $ENV{$name}; + } + + return \%val if keys %val; + + return $self->_get___value(INITIALIZE()) // {}; +} + +sub get_clear_value { + my $self = shift; + return $self->_get___value(CLEAR(), @_) // {}; +} + +sub add_value { + my $self = shift; + my ($ref, %vals) = @_; + + %{$$ref} = ( + %{$$ref}, + %vals, + ); +} + +sub normalize_value { + my $self = shift; + my (@input) = @_; + + return $self->SUPER::normalize_value(@input) if @input > 1; + + if ($input[0] =~ m/^\s*\{.*\}\s*$/s) { + my $out; + local $@; + unless (eval { local $SIG{__DIE__}; $out = decode_json($input[0]); 1 }) { + my ($err) = split /[\n\r]+/, $@; + $err =~ s{at \Q$INC{'Test2/Harness/Util/JSON.pm'}\E line \d+\..*$}{}; + die "Could not decode JSON string: $err\n====\n$input[0]\n====\n"; + } + return %$out; + } + + my @split; + if (my $on = $self->split_on) { + @split = grep { length($_) } map { split($on, $_) } @input; + } + else { + @split = @input; + } + + my $key_on = $self->key_on // '='; + my %output = map { my ($k, $v) = split($key_on, $_, 2); $self->SUPER::normalize_value($k, $v) } @split; + + return %output; +} + +1; diff --git a/lib2.0/Getopt/Yath/Option/Scalar.pm b/lib2.0/Getopt/Yath/Option/Scalar.pm new file mode 100644 index 000000000..f35c362c4 --- /dev/null +++ b/lib2.0/Getopt/Yath/Option/Scalar.pm @@ -0,0 +1,31 @@ +package Getopt::Yath::Option::Scalar; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Getopt::Yath::Option'; +use Test2::Harness::Util::HashBase; + +sub allows_default { 1 } +sub allows_arg { 1 } +sub requires_arg { 1 } +sub allows_autofill { 0 } +sub requires_autofill { 0 } + +sub is_populated { defined(${$_[1]}) ? 1 : 0 } + +sub add_value { ${$_[1]} = $_[2] } + +sub can_set_env { 1 } + +sub get_env_value { + my $opt = shift; + my ($var, $ref) = @_; + + return $$ref unless $var =~ m/^!/; + return $ref ? 0 : 1; +} + + +1; diff --git a/lib2.0/Getopt/Yath/Settings.pm b/lib2.0/Getopt/Yath/Settings.pm new file mode 100644 index 000000000..6b36c0ab6 --- /dev/null +++ b/lib2.0/Getopt/Yath/Settings.pm @@ -0,0 +1,68 @@ +package Getopt::Yath::Settings; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Getopt::Yath::Settings::Group; +use Carp(); + +sub new { + my $class = shift; + my $self = @_ > 1 ? { @_ } : $_[0]; + + bless($self, $class); + + Getopt::Yath::Settings::Group->new($_) for values %$self; + + return $self; +} + +sub check_group { $_[0]->{$_[1]} ? 1 : 0 } + +sub group { + my $self = shift; + my ($group, $vivify) = @_; + + return $self->{$group} if $self->{$group}; + + return $self->{$group} = Getopt::Yath::Settings::Group->new() + if $vivify; + + Carp::croak("The '$group' group is not defined"); +} + +sub create_group { + my $self = shift; + my ($name, @vals) = @_; + + return $self->{$name} = Getopt::Yath::Settings::Group->new(@vals > 1 ? { @vals } : $vals[0]); +} + +sub delete_group { + my $self = shift; + my ($name) = @_; + + delete $self->{$name}; +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $this = shift; + + my $group = $AUTOLOAD; + $group =~ s/^.*:://g; + + return if $group eq 'DESTROY'; + + Carp::croak("Method $group() must be called on a blessed instance") unless ref($this); + + $this->group($group); +} + +sub TO_JSON { + my $self = shift; + return {%$self}; +} + +1; diff --git a/lib2.0/Getopt/Yath/Settings/Group.pm b/lib2.0/Getopt/Yath/Settings/Group.pm new file mode 100644 index 000000000..702617662 --- /dev/null +++ b/lib2.0/Getopt/Yath/Settings/Group.pm @@ -0,0 +1,82 @@ +package Getopt::Yath::Settings::Group; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp(); + +sub new { + my $class = shift; + my $self = (@_ != 1) ? { @_ } : $_[0]; + + return bless($self, $class); +} + +sub all { return %{$_[0]} } + +sub check_option { exists($_[0]->{$_[1]}) ? 1 : 0 } + +sub option :lvalue { + my $self = shift; + my ($option, @vals) = @_; + + Carp::croak("Too many arguments for option()") if @vals > 1; + Carp::croak("The '$option' option does not exist") unless exists $self->{$option}; + + ($self->{$option}) = @vals if @vals; + + return $self->{$option}; +} + +sub create_option { + my $self = shift; + my ($name, $val) = @_; + + $self->{$name} = $val; + + return $self->{$name}; +} + +sub option_ref { + my $self = shift; + my ($name, $create) = @_; + + Carp::croak("The '$name' option does not exist") unless $create || exists $self->{$name}; + + return \($self->{$name}); +} + +sub delete_option { + my $self = shift; + my ($name) = @_; + + delete $self->{$name}; +} + +sub remove_option { + my $self = shift; + my ($name) = @_; + delete ${$self}->{$name}; +} + +our $AUTOLOAD; +sub AUTOLOAD : lvalue { + my $this = shift; + + my $option = $AUTOLOAD; + $option =~ s/^.*:://g; + + return if $option eq 'DESTROY'; + + Carp::croak("Method $option() must be called on a blessed instance") unless ref($this); + + $this->option($option, @_); +} + +sub TO_JSON { + my $self = shift; + return {%$self}; +} + +1; diff --git a/lib2.0/Getopt/Yath/Term.pm b/lib2.0/Getopt/Yath/Term.pm new file mode 100644 index 000000000..b31c22d49 --- /dev/null +++ b/lib2.0/Getopt/Yath/Term.pm @@ -0,0 +1,54 @@ +package Getopt::Yath::Term; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +our @EXPORT = qw/color term_size fit_to_width/; +use Importer Importer => 'import'; + +BEGIN { + unless (eval { require Term::Table::Util; Term::Table::Util->import(qw/term_size/); 1 }) { + *term_size = sub() { 80 }; + } + + if (eval { require Term::ANSIColor; ($ENV{CLICOLOR_FORCE} || $ENV{YATH_COLOR} || -t STDOUT) ? 1 : 0 }) { + *color = sub() { 1 }; + } + else { + *color = sub() { 0 }; + } +} + +sub fit_to_width { + my ($join, $text, $prefix) = @_; + + my $width = term_size() - 20; + $width = 80 unless $width && $width >= 80; + + my @parts = ref($text) ? @$text : split /\s+/, $text; + + my @out; + + my $line = ""; + for my $part (@parts) { + my $new = $line ? "$line$join$part" : $part; + + if ($line && length($new) > $width) { + push @out => $line; + $line = $part; + } + else { + $line = $new; + } + } + push @out => $line if $line; + + if(defined $prefix) { + $_ =~ s/^/ /gm for @out; + } + + return join "\n" => @out; +} + +1; diff --git a/lib2.0/IPC/StateFile.pm b/lib2.0/IPC/StateFile.pm new file mode 100644 index 000000000..fe3937dd7 --- /dev/null +++ b/lib2.0/IPC/StateFile.pm @@ -0,0 +1,512 @@ +package IPC::StateFile; +use strict; +use warnings; + +use Carp qw/confess croak/; +use Errno qw/EINTR EAGAIN/; +use Fcntl qw/:flock/; +use Scalar::Util qw/weaken blessed/; +use Test2::Harness::Util qw/mod2file/; +use Test2::Harness::Util::File::JSON; + +use Test2::Harness::Util::HashBase qw/<state_file <state_mask +txn <read_only <cache before_write after_write/; + +use IPC::StateFile::RPCObject; +use IPC::StateFile::RPCObject::Process; + +sub object_map { {} } + +sub lock_file { + my $class_or_file = shift; + my ($file) = @_; + + $file //= $class_or_file->state_file; + + return "$file.LOCK"; +} + +sub create_check {} +sub connect_check {} + +sub new { confess "new() is not supported, use create() or connect()" } + +sub create { + my $class = shift; + my ($state_file, %params) = @_; + + confess "A state file is required" unless $state_file; + + my $lock_file = $class->lock_file($state_file); + my $lock = $class->_lock($lock_file, 1, 0); + confess "State file already exists" if -e $state_file; + confess "Could not get lock" unless $lock; + + my $mask = delete($params{mask}) // 0007; + + my $self = bless( + { + state_file => $state_file, + state_mask => $mask, + cache => {}, + }, + $class + ); + + # Vivify the file. + $self->transaction( + lock => $lock, + mode => 'w', + cb => sub { + my $map = $self->object_map; + + for my $field (keys %params) { + if (my $spec = $map->{$field}) { + confess "Cannot intitialize '$field' from create()" if $spec->{ipc} || $spec->{depth}; + $self->set($field, $params{$field}); + } + else { + $self->{$field} = $params{$field}; + } + } + + $self->create_check(%params); + } + ); + + return $self; +} + +sub connect { + my $class = shift; + my ($state_file, %params) = @_; + + confess "A state file is required" unless $state_file; + confess "'$state_file' does not exist, or is not a regular file" unless -f $state_file; + + my $mask = delete($params{mask}) // 0007; + + my $self = bless( + { + state_file => $state_file, + state_mask => $mask, + read_only => $params{read_only}, + cache => {}, + }, + $class + ); + + my $map = $self->object_map; + + for my $field (keys %params) { + confess "Cannot intitialize '$field' from connect()" if $map->{$field}; + $self->{$field} = $params{$field}; + } + + $self->connect_check(%params); + + return $self; +} + +sub _read_data { + my $self = shift; + + return {} unless -e $self->{+STATE_FILE}; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + + my ($ok, $err, $data); + for (1 .. 10) { + $ok = eval { $data = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.1; + } + + die "Corrupted data? Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + return $data // {}; +} + +sub _write_data { + my $self = shift; + my ($data) = @_; + + my $state = $self->{+TXN} // {}; + + confess("Attempted write with no lock") unless $state->{lock}; + confess("Attempted write with a read-only lock") unless $state->{write}; + + my $data_copy = {%$data}; + + my $oldmask = umask($self->{+STATE_MASK}); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + $file->rewrite($data_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +sub txn { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $mode //= ''; + croak("mode must be 'w', 'rw', 'r', or 'ro', got '$mode'") unless $mode =~ m/^(w|rw|r|ro)$/; + + $self->transaction( + mode => $mode, + callback => $cb, + args => \@args, + ); +} + +sub _lock { + my $self_or_class = shift; + my ($lockf, $write, $block) = @_; + + $lockf //= $self_or_class->lock_file; + + my $lock; + open($lock, ((-f $lockf) ? '>>' : '>'), $lockf) or die "Could not open lock file '$lockf': $!"; + + my $flags = $write ? LOCK_EX : LOCK_SH; + $flags |= LOCK_NB unless $block; + + while (1) { + last if flock($lock, $flags); + return unless $block; + next if $! == EINTR || $! == EAGAIN; + die "Could not get lock: $!"; + } + + return $lock; +} + +sub transaction { + my $self = shift; + my %params = @_; + + my $lock = $params{lock}; + my $mode = $params{mode} // 'r'; + my $cb = $params{callback} // $params{cb}; + my $args = $params{args} // []; + my $block = defined($params{blocking}) ? $params{blocking} : 1; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + croak("mode must be 'w', 'rw', 'r', or 'ro', got '$mode'") unless $write || $read; + + my $before_write = $params{before_write} // $self->before_write; + my $after_write = $params{after_write} // $self->after_write; + + my ($state, $data, $nested); + if ($state = $self->{+TXN}) { + $nested = 1; + + confess("Attempted a 'write' transaction inside of a read-only transaction") + if $write && !$state->{write}; + + $data = $state->{data}; + } + else { + $nested = 0; + + my $oldmask = umask($self->{+STATE_MASK}); + my $return = 0; + my $ok = eval { + $lock //= $self->_lock($self->lock_file, $write, $block); + return $return = 1 unless $lock; + $data = $self->_read_data(); + 1; + }; + my $err = $@; + umask($oldmask); + return if $return; + die $err unless $ok; + + $state = { + lock => $lock, + mode => $mode, + write => $write, + data => $data, + pid => $$, + }; + + $self->{+TXN} = $state; + + weaken($state->{lock}); + } + + local @{$state}{qw/write mode/} = ($write, $mode); + + my $out; + my $ok = eval { + $out = $cb ? $self->$cb(@$args) : $data; + + if ($write && $state->{pid} == $$ && !$nested) { + $self->$before_write($data) if $before_write; + $self->_write_data($data); + $self->$after_write($data) if $after_write; + } + + 1; + }; + my $err = $@; + + if ($lock && !$params{lock}) { + unless (flock($lock, LOCK_UN)) { + my $prob = "Could not release lock: $!"; + $ok ? die $prob : warn $prob; + } + } + + delete $self->{+TXN} unless $nested; + + die $err unless $ok; + + return $out; +} + +sub _ref { + my $self = shift; + my (@ids) = @_; + + my $cref = \($self->{+CACHE}); + my $dref = \($self->{+TXN}->{data}); + + for my $id (@ids) { + $dref = \(${$dref}->{$id}); + $cref = \(${$cref}->{$id}); + } + + return ($cref, $dref); +} + +sub set { + my $self = shift; + my $type = shift; + my $obj = pop; + my $ids = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : [@_]; + + my $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + croak "'$type' is not a shared object (use init() instead of set())" if $spec->{ipc} || $spec->{process} || !$spec->{shared}; + croak "Too many levels of identifier keys, got " . scalar(@$ids) . ", max $spec->{depth}" if @$ids > $spec->{depth}; + + my $class = blessed($obj); + if ($class) { + croak "Object '$obj' does not have a TO_JSON() method" unless $obj->can('TO_JSON'); + croak "Object '$obj' does not have a FROM_JSON() method" unless $obj->can('FROM_JSON'); + } + + $self->txn( + w => sub { + my ($cref, $dref) = $self->_ref($type, @$ids); + + confess join('->', $type, @$ids) . " is already set" + if $$cref || $$dref; + + $$dref = $class ? [$obj, $class] : [$obj]; + + return $obj; + }, + ); +} + +sub init { + my $self = shift; + my $type = shift; + my $specs = pop; + my $class = pop; + my $ids = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : [@_]; + + my $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + croak "'$type' is a shared object (use set() instead of init())" if $spec->{shared}; + croak "Too many levels of identifier keys, got " . scalar(@$ids) . ", max $spec->{depth}" if @$ids > $spec->{depth}; + + require(mod2file($class)); + croak "'$class' does not inherit from 'IPC::StateFile::RPCObject'" + if $spec->{rpc} && !$class->isa('IPC::StateFile::RPCObject'); + + croak "'$class' does not inherit from 'IPC::StateFile::RPCObject::Process'" + if $spec->{process} && !$class->isa('IPC::StateFile::RPCObject::Process'); + + $self->txn( + w => sub { + my ($cref, $dref) = $self->_ref($type, @$ids); + + confess join('->', $type, @$ids) . " is already initialized" + if $$cref || $$dref; + + $$dref = [{}, $class]; + + my $obj = $class->new(%$specs, state => $self, state_path => [$type, @$ids]); + + $$cref = $obj; + weaken($cref); + + return $obj; + }, + ); +} + +sub _inflate { + my $self = shift; + my ($spec, $cref, $dref, $ids) = @_; + + unless (defined $$dref) { + $$cref = undef; + return undef; + } + + return $$cref if defined $$cref; + + my ($data, $class) = @$$dref; + + my $inst; + if ($class && !blessed($data)) { + require(mod2file($class)); + if ($spec->{shared}) { + $inst = $class->FROM_JSON($data); + } + else { + $inst = $class->inflate($self, $ids); + } + } + else { + $inst = $data; + } + + if ($spec->{rpc}) { + $$cref = $inst; + weaken($$cref); + } + + return $inst; +} + +sub get_data { + my $self = shift; + my $type = shift; + my $ids = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : [@_]; + + my $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + + croak "Incorrect number of identifier keys, got " . scalar(@$ids) . " need $spec->{depth}" unless @$ids == $spec->{depth}; + + my $out; + + $self->txn(r => sub { + my ($cref, $dref) = $self->_ref($type, @$ids); + $out = ${$dref}->[0]; + }); + + return $out; +} + +sub get { + my $self = shift; + my $type = shift; + my $ids = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : [@_]; + + my $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + + croak "Incorrect number of identifier keys, got " . scalar(@$ids) . " need $spec->{depth}" unless @$ids == $spec->{depth}; + + my $inst; + + $self->txn(r => sub { + my ($cref, $dref) = $self->_ref($type, @$ids); + $inst = $self->_inflate($spec, $cref, $dref, [$type, @$ids]); + }); + + return $inst; +} + +sub del { + my $self = shift; + my $type = shift; + my $ids = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? shift : [@_]; + + croak "type argument is required" unless $type; + my $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + croak "Too many levels of identifier keys, got " . scalar(@$ids) . ", max $spec->{depth}" if @$ids > $spec->{depth}; + + my @search = ($type, @$ids); + my $last = pop(@search); + + $self->txn(w => sub { + my ($cref, $dref) = $self->_ref(@search); + + delete ${$cref}->{$last}; + delete ${$dref}->{$last}; + + return; + }); + + return; +} + +sub list { + my $self = shift; + my @todo = (@_ && ref $_[0]) ? @_ : ([@_]); + + my @out; + + $self->txn(r => sub { + while (my $set = shift @todo) { + my ($type, @ids) = @$set; + + my $spec; + if ($type) { + $spec = $self->object_map->{$type} or croak "Unsupported type '$type'"; + croak "Too many levels of identifier keys, got " . scalar(@ids) . ", max $spec->{depth}" if @ids > $spec->{depth}; + unshift @ids => $type; + } + + my ($cref, $dref) = $self->_ref(@ids); + next unless $$dref; + + my $rtype = ref($$dref); + if ($rtype eq 'HASH') { + push @todo => map { [@ids, $_] } keys %$$dref; + next; + } + + confess "Unsupported type '$type'" unless $spec; + push @out => $self->_inflate($spec, $cref, $dref, \@ids); + } + }); + + return @out; +} + +sub list_rpc { shift->_list('rpc') } +sub list_shared { shift->_list('shared') } +sub list_processes { shift->_list('process') } +sub list_procs { shift->_list('process') } + +sub _list { + my $self = shift; + my ($want) = @_; + + my @searches; + my $map = $self->object_map; + + for my $type (keys %$map) { + my $spec = $map->{$type}; + next unless $spec->{$want}; + push @searches => [$type]; + } + + return $self->_list(@searches); +} + +1; diff --git a/lib2.0/IPC/StateFile/RPCObject.pm b/lib2.0/IPC/StateFile/RPCObject.pm new file mode 100644 index 000000000..ddcbcd775 --- /dev/null +++ b/lib2.0/IPC/StateFile/RPCObject.pm @@ -0,0 +1,124 @@ +package IPC::StateFile::RPCObject; +use strict; +use warnings; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw/<state <state_path/; + +sub shared_fields { {} } + +sub inflate { + my $class = shift; + my ($state, $path) = @_; + + croak "'state' is a required attribute" unless $state; + croak "'state_path' is a required attribute" unless $path; + + croak "'state' must be an instance of a 'IPC::StateFile' subclass" unless $state->isa('IPC::StateFile'); + croak "'state_path' cannot be an empty list" unless @{$path}; + + return bless({state => $state, state_path => $path}, $class); +} + +sub init { + my $self = shift; + + croak "'state' is a required attribute" unless $self->state; + croak "'state_path' is a required attribute" unless $self->state_path; + + croak "'state' must be an instance of a 'IPC::StateFile' subclass" unless $self->state->isa('IPC::StateFile'); + croak "'state_path' cannot be an empty list" unless @{$self->state_path}; + + my %shared; + for my $field (keys %{$self->shared_fields}) { + next unless exists $self->{$field}; + $shared{$field} = delete $self->{$field}; + } + + $self->set_fields(%shared); + + return $self; +} + +sub fields { shift->txn('r') } + +sub get_field { + my $self = shift; + my ($field) = @_; + + croak "'$field' is not a valid field" unless $self->shared_fields->{$field}; + + return $self->txn('r' => sub { $_[1]->{$field} }); +} + +sub get_fields { + my $self = shift; + my (@fields) = @_; + + for my $field (@fields) { + croak "'$field' is not a valid field" unless $self->shared_fields->{$field}; + } + + return @{ $self->txn('r' => sub { [@{$_[1]}{@fields}] }) // [] }; +} + +*set_field = \&set_fields; +sub set_fields { + my $self = shift; + my (%fields) = @_; + + for my $field (keys %fields) { + croak "'$field' is not a valid field" unless $self->shared_fields->{$field}; + } + + $self->txn(w => sub { + my $data = $_[1] // {}; + %$data = (%$data, %fields); + }); + + return; +} + +*del_field = \&del_fields; +sub del_fields { + my $self = shift; + my (@fields) = @_; + + for my $field (@fields) { + croak "'$field' is not a valid field" unless $self->shared_fields->{$field}; + } + + $self->txn('w' => sub { delete $_[1]->{$_} for @fields }); + + return; +} + +sub txn { + my $self = shift; + my ($mode, $cb, @args) = @_; + + return $self->transaction(mode => $mode, cb => $cb, args => \@args); +} + +sub transaction { + my $self = shift; + my %params = @_; + + my $state = $self->state; + my $path = $self->state_path; + + my $cb = delete $params{cb}; + + $state->transaction( + %params, + + cb => sub { + my $data = $state->get_data(@$path); + return $data unless $cb; + return $self->$cb($data, @_); + }, + ); +} + +1; diff --git a/lib2.0/IPC/StateFile/RPCObject/Process.pm b/lib2.0/IPC/StateFile/RPCObject/Process.pm new file mode 100644 index 000000000..12a866920 --- /dev/null +++ b/lib2.0/IPC/StateFile/RPCObject/Process.pm @@ -0,0 +1,131 @@ +package IPC::StateFile::RPCObject::Process; +use strict; +use warnings; + +use Carp qw/confess/; +use POSIX ":sys_wait_h"; + +use Test2::Harness::Util::IPC qw/pid_is_running/; + +use parent 'IPC::StateFile::RPCObject'; +use Test2::Harness::Util::HashBase qw//; + +sub shared_fields { + my $self = shift; + + return { + %{$self->SUPER::shared_fields(@_)}, + pids => 1, + ppid => 1, + exit => 1, + }; +} + +sub proc_name { + my $self = shift; + my $type = ref($self); + $type =~ s/^.*:://; + $type = lc($type); + + return "$0-$type"; +} + +sub spawn { + my $self = shift; + my %params = @_; + + my $run_method = $params{run_method} // 'run'; + confess "Invalid run method '$run_method'" unless ref($run_method) eq 'CODE' || $self->can($run_method); + + my $pid; + + $self->txn(w => sub { + confess "Process is already running" if $self->get_field('pids'); + + $pid = fork // die "Could not fork: $!"; + $self->set_fields(ppid => $$, pids => [$pid]) if $pid; + }); + + $self->txn('r'); # Make sure the previous txn is done in both processes. + + return $pid if $pid; + + $0 = delete($params{proc_name}) || $self->proc_name; + + if (my $pfcb = delete $params{post_fork}) { + $self->$pfcb(); + } + + unless(eval { exit($self->$run_method(%params) // 0); 1 }) { + warn($@); + exit(255); + } + + confess("Escaped scope after spawned call to '$self->$run_method()'"); + exit(255); +} + +sub is_my_child { + my $self = shift; + + my ($pids, $ppid) = $self->get_fields(qw/pids ppid/); + confess "Proces not started" unless $pids && @$pids; + return unless $$ == $ppid; + return 1; +} + +sub wait { + my $self = shift; + my ($flags) = @_; + + $flags //= 0; + + my ($pids, $ppid) = $self->get_fields(qw/pids ppid/); + + confess "Process not started" unless $pids && @$pids; + confess "Not process parent" unless $$ == $ppid; + local $?; + + my ($pid) = @$pids; + my $check = waitpid($pid, $flags); + my $exit = $?; + if ($check == $pid) { + $self->txn(w => sub { + $self->set_field(exit => $exit); + $self->del_fields(qw/ppid pids/); + }); + } + + return ($check, $exit); +} + +sub is_running { + my $self = shift; + + my ($pids, $ppid) = $self->get_fields(qw/pids ppid/); + return unless $pids && @$pids; + + if ($$ == $ppid) { + my ($check) = $self->wait(WNOHANG); + return 0 if $check > 0; + } + + my @out; + for my $pid (@$pids) { + push @out => $pid if pid_is_running($pid); + } + + return @out; +} + +sub kill { + my $self = shift; + my ($sig) = @_; + + my @pids = $self->is_running; + return unless @pids; + + return kill($sig, @pids); +} + +1; diff --git a/lib2.0/Test2/Formatter/Stream.pm b/lib2.0/Test2/Formatter/Stream.pm new file mode 100644 index 000000000..d14999177 --- /dev/null +++ b/lib2.0/Test2/Formatter/Stream.pm @@ -0,0 +1,518 @@ +package Test2::Formatter::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Time::HiRes qw/time/; +use IO::Handle; +use File::Spec(); +use List::Util qw/first/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/JSON JSON_IS_XS/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; + +use Test2::Util qw/get_tid ipc_separator/; + +use parent qw/Test2::Formatter/; +use Test2::Util::HashBase qw/-io _encoding _no_header _no_numbers _no_diag -stream_id -tb -tb_handles -dir -_pid -_tid -_fh <job_id -ugids/; + +BEGIN { + no warnings 'once'; + + if (my $use_pipe = $ENV{T2_HARNESS_USE_ATOMIC_PIPE}) { + require Atomic::Pipe; + *USE_PIPE = sub() { 1 }; + $Test2::Harness::STDOUT_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDOUT); + $Test2::Harness::STDOUT_APIPE->set_mixed_data_mode(); + + if ($use_pipe > 1) { + *USE_PIPE_STDERR = sub() { 1 }; + $Test2::Harness::STDERR_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDERR); + $Test2::Harness::STDERR_APIPE->set_mixed_data_mode(); + } + else { + *USE_PIPE_STDERR = sub() { 0 }; + } + } + else { + *USE_PIPE = sub() { 0 }; + *USE_PIPE_STDERR = sub() { 0 }; + $Test2::Harness::STDOUT_APIPE = undef; + $Test2::Harness::STDERR_APIPE = undef; + } +} + + + +BEGIN { + my $J = JSON->new; + $J->indent(0); + $J->convert_blessed(1); + $J->allow_blessed(1); + $J->utf8(1); + $J->ascii(1); + + require constant; + constant->import(ENCODER => $J); + + if (JSON_IS_XS) { + require JSON::PP; + my $JPP = JSON::PP->new; + $JPP->indent(0); + $JPP->convert_blessed(1); + $JPP->allow_blessed(1); + $JPP->utf8(1); + $JPP->ascii(1); + + constant->import(ENCODER_PP => $JPP); + } +} + +my ($ROOT_TID, $ROOT_PID, $ROOT_DIR, $ROOT_JOB_ID, $ROOT_UGIDS); +sub import { + my $class = shift; + my %params = @_; + + confess "$class no longer accept the 'file' argument, it now takes a 'dir' argument" + if exists $params{file}; + + $class->SUPER::import(); + + $ROOT_PID = $$; + $ROOT_TID = get_tid(); + $ROOT_DIR = $params{dir} if $params{dir}; + $ROOT_JOB_ID = $params{job_id} if $params{job_id}; + $ROOT_UGIDS = [$<, $>, $(, $)]; + + if ($ROOT_DIR && ! -d $ROOT_DIR) { + mkdir($ROOT_DIR) or die "Could not make root dir: $!"; + } +} + +sub hide_buffered { 0 } + +sub fh { + my $self = shift; + + my $dir = $self->{+DIR} or return undef; + + my $pid = $self->{+_PID}; + my $tid = $self->{+_TID}; + + if ($pid && $pid != $$) { + delete $self->{+_PID}; + delete $self->{+_FH}; + } + + if ($tid && $tid != get_tid()) { + delete $self->{+_TID}; + delete $self->{+_FH}; + } + + return $self->{+_FH} if $self->{+_FH}; + + $self->{+STREAM_ID} = 1; + + $pid = $self->{+_PID} = $$; + $tid = $self->{+_TID} = get_tid(); + + my $file = File::Spec->catfile($dir, join(ipc_separator() => 'events', $pid, $tid) . ".jsonl"); + + my @now = ($<, $>, $(, $)); + local ($<, $>, $(, $)) = @{$self->{+UGIDS}} if $self->{+UGIDS} && first { $self->{+UGIDS}->[$_] ne $now[$_] } 0 .. $#now; + + mkdir($dir) or die "Could not make dir '$dir': $!" unless -d $dir; + confess "File '$file' already exists!" if -f $file; + open(my $fh, '>', $file) or die "Could not open file: $file"; + $fh->autoflush(1); + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + return $self->{+_FH} = $fh; +} + +sub init { + my $self = shift; + + $self->{+STREAM_ID} = 1; + $self->{+UGIDS} //= [$<, $>, $(, $)]; + + # To create necessary directories as soon as possible + $self->fh(); + + for (@{$self->{+IO}}) { + $_->autoflush(1); + } + + STDOUT->autoflush(1); + STDERR->autoflush(1); + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stdout()->autoflush(1); + Test2::API::test2_stderr()->autoflush(1); + } + + if ($self->{check_tb}) { + require Test::Builder::Formatter; + $self->{+TB} = Test::Builder::Formatter->new(); + $self->{+TB_HANDLES} = [@{$self->{+TB}->handles}]; + } +} + +sub new_root { + my $class = shift; + my %params = @_; + + $ROOT_PID = $$ unless defined $ROOT_PID; + $ROOT_TID = get_tid() unless defined $ROOT_TID; + + confess "new_root called from child process!" + if $ROOT_PID != $$; + + confess "new_root called from child thread!" + if $ROOT_TID != get_tid(); + + require Test2::API; + my $io = $params{+IO} = [Test2::API::test2_stdout(), Test2::API::test2_stderr()]; + $_->autoflush(1) for @$io; + + confess "T2_STREAM_FILE is no longer used, see T2_STREAM_DIR" + if exists $ENV{T2_STREAM_FILE}; + + $params{+DIR} ||= $ENV{T2_STREAM_DIR} || $ROOT_DIR; + $params{+JOB_ID} ||= $ENV{T2_STREAM_JOB_ID} || $ROOT_JOB_ID || 1; + + # DO NOT REOPEN THEM! + delete $ENV{T2_FORMATTER} if $ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} eq 'Stream'; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_JOB_ID}; + $ROOT_DIR = undef; + + $params{check_tb} = 1 if $INC{'Test/Builder.pm'}; + + $params{+UGIDS} = $ROOT_UGIDS if $ROOT_UGIDS; + + return $class->new(%params); +} + +sub record { + my $self = shift; + my ($facets, $num) = @_; + + my $stamp = time; + my $times = [times]; + + my @sync = @{$self->{+IO}}; + my $leader = 0; + + my $fh = $self->fh; + unless($fh) { + $leader = 1; + $fh = shift @sync; + } + + if ($facets->{control}->{halt}) { + my $reason = $facets->{control}->{details} || ""; + + if ($leader) { + print $fh "\nBail out! $reason\n"; + } + else { + open(my $bh, '>', File::Spec->catfile($self->{+DIR}, 'bail')) or die "Could not create bail file: $!"; + print $bh $reason; + close($bh); + } + } + + my $tid = get_tid(); + my $id = $self->{+STREAM_ID}++; + my $event_id = $facets->{about}->{uuid} ||= gen_uuid(); + + my $json; + { + no warnings 'once'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + + if (JSON_IS_XS) { + for my $encoder (ENCODER, ENCODER_PP) { + local $@; + my $ok = eval { + $json = $encoder->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + 1; + }; + my $err = $@; + last if $ok; + + # Intercept bug in JSON::XS so we can fall back to JSON::PP + next if $encoder eq ENCODER && $err =~ m/Modification of a read-only value attempted/; + + # Different error, time to die. + die $err; + } + } + else { + $json = ENCODER->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + } + } + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $job_id = $self->{+JOB_ID}; + + if (USE_PIPE) { + $Test2::Harness::STDOUT_APIPE->write_message($json); + $Test2::Harness::STDERR_APIPE->write_message(qq/{"event_id":"$event_id"}/) if USE_PIPE_STDERR; + } + else { + print $fh $leader ? ("T2-HARNESS-$job_id-EVENT: ", $json, "\n") : ($json, "\n"); + print $_ "T2-HARNESS-$job_id-ESYNC: ", join(ipc_separator() => $$, $tid, $id) . "\n" for @sync; + } +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + $self->record({control => {encoding => $enc}}); + $self->_set_encoding($enc); + $self->{+TB}->encoding($enc) if $self->{+TB}; + } + + return $self->{+_ENCODING}; +} + +sub _set_encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + apply_encoding(\*STDOUT, $enc); + apply_encoding(\*STDERR, $enc); + + if (!USE_PIPE) { + my $job_id = $self->{+JOB_ID}; + for my $fh (@{$self->{+IO}}) { + print $fh "T2-HARNESS-$job_id-ENCODING: $enc\n"; + apply_encoding($fh, $enc); + } + } + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub { }; +} + +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + $self->_set_encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + # Hide these if we must, but do not remove them for good. + local $f->{info} if $self->{+_NO_DIAG}; + local $f->{plan} if $self->{+_NO_HEADER}; + + my $tb_only = 0; + if ($self->{+TB}) { + $tb_only ||= $self->{+TB_HANDLES}->[0] != $self->{+TB}->{handles}->[0]; + $tb_only ||= $self->{+TB_HANDLES}->[1] != $self->{+TB}->{handles}->[1]; + + my $todo_match = $self->{+TB_HANDLES}->[0] == $self->{+TB}->{handles}->[2] + || $self->{+TB_HANDLES}->[1] == $self->{+TB}->{handles}->[2]; + + $tb_only ||= !$todo_match; + + if ($tb_only) { + my $buffered = hub_truth($f)->{buffered}; + $self->{+TB}->write($e, $num, $f) if $self->{+TB} && !$buffered; + return; + } + } + + $self->record($f, $num); +} + +sub no_header { $_[0]->{+_NO_HEADER} } +sub no_diag { $_[0]->{+_NO_DIAG} } +sub no_numbers { $_[0]->{+_NO_NUMBERS} } + +sub handles { + my $self = shift; + + return $self->{+TB}->handles if $self->{+TB}; + return; +} + +sub set_no_header { + my $self = shift; + ($self->{+_NO_HEADER}) = @_; + $self->{+TB}->set_no_header(@_) if $self->{+TB}; + $self->{+_NO_HEADER}; +} + +sub set_no_diag { + my $self = shift; + ($self->{+_NO_DIAG}) = @_; + $self->{+TB}->set_no_diag(@_) if $self->{+TB}; + $self->{+_NO_DIAG}; +} + +sub set_no_numbers { + my $self = shift; + ($self->{+_NO_NUMBERS}) = @_; + $self->{+TB}->set_no_numbers(@_) if $self->{+TB}; + $self->{+_NO_NUMBERS}; +} + +sub set_handles { + my $self = shift; + return $self->{+TB}->set_handles(@_) if $self->{+TB}; + return; +} + +sub terminate { + my $self = shift; + return $self->SUPER::terminate(@_) unless $self->{+TB}; + return $self->{+TB}->terminate(@_); +} + +sub finalize { + my $self = shift; + return $self->SUPER::finalize(@_) unless $self->{+TB}; + return $self->{+TB}->finalize(@_); +} + +sub DESTROY {} + +our $AUTOLOAD; + +sub AUTOLOAD { + my $this = shift; + + my $meth = $AUTOLOAD; + $meth =~ s/^.*:://g; + + my $type = ref($this); + + return $this->{+TB}->$meth(@_) + if $type && $this->{+TB} && $this->{+TB}->can($meth); + + $type ||= $this; + croak qq{Can't locate object method "$meth" via package "$type"}; +} + +sub isa { + my $in = shift; + return $in->SUPER::isa(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::isa(@_) || $in->{+TB}->isa(@_); +} + +sub can { + my $in = shift; + return $in->SUPER::can(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::can(@_) || $in->{+TB}->can(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Stream - Test2 Formatter that directly writes events. + +=head1 DESCRIPTION + +This formatter writes all test2 events to event files (one per process/thread) +instead of writing them to STDERR/STDOUT. It will output synchronization +messages to STDERR/STDOUT every time an event is written. From this data the +test output can be properly reconstructed in order with STDERR/STDOUT and +events mostly synced so that they appear in the correct order. + +This formatter is not usually useful to humans. This formatter is used by +L<Test2::Harness> when possible to prevent the loss of data that normally +occurs when TAP is used. + +=head1 SYNOPSIS + +If you really want your test to output this: + + use Test2::Formatter::Stream; + use Test2::V0; + ... + +Otherwise just use L<App::Yath> without the C<--no-stream> argument and this +formatter will be used when possible. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Formatter/Test2.pm b/lib2.0/Test2/Formatter/Test2.pm new file mode 100644 index 000000000..3df3bff7a --- /dev/null +++ b/lib2.0/Test2/Formatter/Test2.pm @@ -0,0 +1,808 @@ +package Test2::Formatter::Test2; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Term qw/term_size/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; +use Test2::Util qw/IS_WIN32 clone_io/; +use Scalar::Util qw/blessed/; +use Time::HiRes qw/time/; +use IO::Handle; + +use File::Spec(); +use Test2::Formatter::Test2::Composer; + +use parent 'Test2::Formatter'; + +sub import { + my $class = shift; + return if $ENV{HARNESS_ACTIVE}; + $class->SUPER::import; +} + +use Test2::Util::HashBase qw{ + -composer + -last_depth + -_buffered + <job_io + +io + <enc_io + -_encoding + -show_buffer + -color + -progress + -tty + -no_wrap + -verbose + -job_length + -ecount + -job_colors + -active_files + -_active_disp + -_file_stats + -job_names + -is_persistent + -interactive + +noname_counter +}; + +sub TAG_WIDTH() { 8 } + +sub hide_buffered() { 0 } + +sub DEFAULT_TAG_COLOR() { + return ( + 'DEBUG' => Term::ANSIColor::color('red'), + 'DIAG' => Term::ANSIColor::color('yellow'), + 'ERROR' => Term::ANSIColor::color('red'), + 'FATAL' => Term::ANSIColor::color('bold red'), + 'FAIL' => Term::ANSIColor::color('red'), + 'HALT' => Term::ANSIColor::color('bold red'), + 'PASS' => Term::ANSIColor::color('green'), + '! PASS !' => Term::ANSIColor::color('cyan'), + 'TODO' => Term::ANSIColor::color('cyan'), + 'NO PLAN' => Term::ANSIColor::color('yellow'), + 'SKIP' => Term::ANSIColor::color('bold cyan'), + 'SKIP ALL' => Term::ANSIColor::color('bold white on_blue'), + 'STDERR' => Term::ANSIColor::color('yellow'), + 'RUN INFO' => Term::ANSIColor::color('bold bright_blue'), + 'JOB INFO' => Term::ANSIColor::color('bold bright_blue'), + 'LAUNCH' => Term::ANSIColor::color('bold bright_white'), + 'RETRY' => Term::ANSIColor::color('bold bright_white'), + 'PASSED' => Term::ANSIColor::color('bold bright_green'), + 'TO RETRY' => Term::ANSIColor::color('bold bright_yellow'), + 'FAILED' => Term::ANSIColor::color('bold bright_red'), + 'REASON' => Term::ANSIColor::color('magenta'), + 'TIMEOUT' => Term::ANSIColor::color('magenta'), + 'TIME' => Term::ANSIColor::color('blue'), + 'MEMORY' => Term::ANSIColor::color('blue'), + ); +} + +sub DEFAULT_FACET_COLOR() { + return ( + time => Term::ANSIColor::color('blue'), + memory => Term::ANSIColor::color('blue'), + about => Term::ANSIColor::color('magenta'), + amnesty => Term::ANSIColor::color('cyan'), + assert => Term::ANSIColor::color('bold bright_white'), + control => Term::ANSIColor::color('bold red'), + error => Term::ANSIColor::color('yellow'), + info => Term::ANSIColor::color('yellow'), + meta => Term::ANSIColor::color('magenta'), + parent => Term::ANSIColor::color('magenta'), + trace => Term::ANSIColor::color('bold red'), + ); +} + +# These colors all look decent enough to use, ordered to avoid putting similar ones together +use constant DEFAULT_JOB_COLOR_NAMES => ( + 'bold green on_blue', + 'bold blue on_white', + 'bold black on_cyan', + 'bold green on_bright_black', + 'bold dark blue on_white', + 'bold black on_green', + 'bold cyan on_blue', + 'bold black on_white', + 'bold white on_cyan', + 'bold cyan on_bright_black', + 'bold white on_green', + 'bold bright_black on_white', + 'bold white on_blue', + 'bold bright_cyan on_green', + 'bold blue on_cyan', + 'bold white on_bright_black', + 'bold bright_black on_green', + 'bold bright_green on_blue', + 'bold bright_blue on_white', + 'bold bright_white on_bright_black', + 'bold yellow on_blue', + 'bold bright_black on_cyan', + 'bold bright_green on_bright_black', + 'bold blue on_green', + 'bold bright_cyan on_blue', + 'bold bright_blue on_cyan', + 'bold dark bright_white on_bright_black', + 'bold bright_blue on_green', + 'bold dark bright_blue on_white', + 'bold bright_white on_blue', + 'bold bright_cyan on_bright_black', + 'bold bright_white on_cyan', + 'bold bright_white on_green', + 'bold bright_yellow on_blue', + #'bold magenta on_white', + #'bold dark magenta on_white', + #'bold dark cyan on_white', + 'bold dark bright_cyan on_bright_black', + #'bold dark bright_green on_black', + #'bold dark bright_yellow on_black', +); + +sub DEFAULT_JOB_COLOR() { + return map { Term::ANSIColor::color($_) } DEFAULT_JOB_COLOR_NAMES; +} + +sub DEFAULT_COLOR() { + return ( + reset => Term::ANSIColor::color('reset'), + blob => Term::ANSIColor::color('bold bright_black on_white'), + tree => Term::ANSIColor::color('bold bright_white'), + tag_border => Term::ANSIColor::color('bold bright_white'), + ); +} + +my %FACET_TAG_BORDERS = ( + 'default' => ['[', ']'], + 'amnesty' => ['{', '}'], + 'info' => ['(', ')'], + 'error' => ['<', '>'], + 'parent' => [' ', ' '], +); + +sub init { + my $self = shift; + + $self->{+NONAME_COUNTER} //= 1; + + $self->{+COMPOSER} ||= Test2::Formatter::Test2::Composer->new; + + $self->{+VERBOSE} = 1 unless defined $self->{+VERBOSE}; + + $self->{+JOB_LENGTH} ||= 2; + + my $io = $self->{+IO} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + + $self->{+TTY} = -t $io unless defined $self->{+TTY}; + + my $use_color = ref($self->{+COLOR}) ? 1 : delete($self->{+COLOR}); + $use_color = $self->{+TTY} unless defined $use_color; + + if ($use_color && USE_ANSI_COLOR) { + $self->{+SHOW_BUFFER} = 1 unless defined $self->{+SHOW_BUFFER}; + + if ($use_color) { + $self->{+COLOR} = { + DEFAULT_COLOR(), + TAGS => {DEFAULT_TAG_COLOR()}, + FACETS => {DEFAULT_FACET_COLOR()}, + JOBS => [DEFAULT_JOB_COLOR()], + } unless defined $self->{+COLOR}; + + $self->{+JOB_COLORS} = {free => [@{$self->{+COLOR}->{JOBS}}]}; + } + } + else { + $self->{+SHOW_BUFFER} = 0 unless defined $self->{+SHOW_BUFFER}; + } + + $self->{+ECOUNT} //= 0; + + my $reset = $use_color ? Term::ANSIColor::color('reset') : ''; + my $cyan = $use_color ? Term::ANSIColor::color('cyan') : ''; + $self->{+_ACTIVE_DISP} = ["[${cyan}INITIALIZING${reset}]", '']; + $self->{+_FILE_STATS} = { + passed => 0, + failed => 0, + running => 0, + todo => 0, + total => 0, + }; + + +} + +sub io { + my $self = shift; + my ($job_id) = @_; + return $self->{+IO} unless defined $job_id; + return $self->{+JOB_IO}->{$job_id} // $self->{+IO}; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc, $job_id) = @_; + if (defined $job_id) { + my $io; + + unless ($io = $self->{+ENC_IO}->{$enc}) { + $io = $self->{+ENC_IO}->{$enc} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + apply_encoding($io, $enc); + } + + $self->{+JOB_IO}->{$job_id} = $io; + } + else { + apply_encoding($self->{+IO}, $enc); + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= blessed($e) ? $e->facet_data : $e->{facet_data}; + + my $should_show = $self->update_active_disp($f); + + $self->{+ECOUNT}++; + + my $job_id = $f->{harness}->{job_id}; + $self->encoding($f->{control}->{encoding}, $job_id) if $f->{control}->{encoding}; + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + return if $depth && (!$self->{+SHOW_BUFFER} || !$self->{+PROGRESS}); + + my $lines; + if (!$self->{+VERBOSE}) { + if ($depth) { + $lines = []; + } + else { + $lines = $self->render_quiet($f); + } + } + elsif ($depth) { + my $tree = $self->render_tree($f, '>'); + $lines = $self->render_buffered_event($f, $tree); + } + else { + my $tree = $self->render_tree($f,); + $lines = $self->render_event($f, $tree); + } + + $should_show ||= $lines && @$lines; + unless ($should_show || $self->{+VERBOSE}) { + if (my $last = $self->{last_rendered}) { + return if time - $last < 0.2; + $self->{last_rendered} = time; + } + else { + $self->{last_rendered} = time; + } + } + + push @{$self->{+JOB_COLORS}->{free}} => delete $self->{+JOB_COLORS}->{used}->{$job_id} + if $job_id && $f->{harness_job_end}; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->io($job_id); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if (!$self->{+VERBOSE}) { + print $io $_, "\n" for @$lines; + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + } + elsif ($depth && $lines && @$lines && !$self->{+INTERACTIVE}) { + print $io $lines->[0]; + $self->{+_BUFFERED} = 1; + } + else { + print $io $_, "\n" for @$lines; + } + + delete $self->{+JOB_IO}->{$job_id} if $job_id && $f->{harness_job_end}; +} + +sub finalize { + my $self = shift; + + my $io = $self->{+IO}; + print $io "\r\e[K" if $self->{+_BUFFERED}; + + return; +} + +sub step { + my $self = shift; + + return unless $self->update_active_disp; + + my $io = $self->io(0); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status(); + $self->{+_BUFFERED} = 1; + } +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + my $should_show = 0; + + my $stats = $self->{+_FILE_STATS}; + + my $out = 0; + $out = $self->update_spinner($stats) unless $stats->{started}; + + return $out unless $f; + + if (my $task = $f->{harness_job_queued}) { + $self->{+JOB_NAMES}->{$task->{job_id}} = $task->{job_name} || $task->{job_id}; + $stats->{total}++; + $stats->{todo}++; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($job->{file})} = $job->{job_name} || $job->{job_id}; + $should_show = 1; + $stats->{running}++; + $stats->{todo}--; + $stats->{started} //= 1; + } + + if ($f->{harness_job_end}) { + my $file = $f->{harness_job_end}->{file}; + delete $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($file)}; + $should_show = 1; + $stats->{running}--; + + if ($f->{harness_job_end}->{fail}) { + $stats->{failed}++; + } + else { + $stats->{passed}++; + } + } + + return $out unless $should_show; + + my $statline = join '|' => ( + $self->_highlight($stats->{passed}, 'P', 'green'), + $self->_highlight($stats->{failed}, 'F', 'red'), + $self->_highlight($stats->{running}, 'R', 'cyan'), + $self->_highlight($stats->{todo}, 'T', 'yellow'), + ); + + $statline = "[$statline]"; + + my $active = $self->{+ACTIVE_FILES}; + + return $self->{+_ACTIVE_DISP} = [$statline, ''] unless $active && keys %$active; + + my $reset = $self->reset; + + my $str .= "("; + { + no warnings 'numeric'; + $str .= join(' ' => map { m{([^/]+)$}; "$active->{$_}:$1" } sort { ($active->{$a} || 0) <=> ($active->{$b} || 0) or $a cmp $b } keys %$active); + } + $str .= ")"; + + $self->{+_ACTIVE_DISP} = [$statline, $str]; + + return 1; +} + +sub update_spinner { + my $self = shift; + my ($stats) = @_; + + $stats->{spinner} //= '|'; + $stats->{spinner_time} //= time - 1; + $stats->{blink_time} //= time - 1; + $stats->{blink} //= ''; + + if (time - $stats->{spinner_time} > 0.1) { + $stats->{spinner_time} = time; + my $start = substr($stats->{spinner}, 0, 1); + $stats->{spinner} = '\\' if $start eq '-'; + $stats->{spinner} = '-' if $start eq '/'; + $stats->{spinner} = '/' if $start eq '|'; + $stats->{spinner} = '|' if $start eq '\\'; + } + elsif(time - $stats->{blink_time} > 0.5) { + $stats->{blink_time} = time; + $stats->{blink} = $stats->{blink} ? '' : 'bold bright_'; + } + else { + return 0; + } + + my $yellow = $self->{+COLOR} ? Term::ANSIColor::color($stats->{blink} . 'yellow') : ''; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + my $green = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_green') : ''; + my $bold = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_white') : ''; + my $reset = $self->reset; + + $self->{+_ACTIVE_DISP} = [ + join( + '' => ( + $bold => "[ ", $reset, + $green => $stats->{spinner}, $reset, + '' => " ", + $self->{+IS_PERSISTENT} + ? ( + $yellow => "Waiting for busy runner", $reset, + '' => " ", + $reset => "(see ", $reset, + $cyan => "yath status", $reset, + $reset => ")", $reset, + ) + : ($yellow => "INITIALIZING", $reset), + '' => " ", + $green => $stats->{spinner}, $reset, + $bold => " ]", $reset, + ) + ), + '', + ]; + + return 1; +} + +sub _highlight { + my $self = shift; + my ($val, $label, $color) = @_; + + return "${label}:${val}" unless $val && $self->{+COLOR}; + return sprintf('%s%s:%d%s', Term::ANSIColor::color($color), $label, $val, $self->reset); +} + + +sub colorstrip { + my $self = shift; + my ($str) = @_; + + return $str unless USE_ANSI_COLOR; + return Term::ANSIColor::colorstrip($str); +} + +sub render_status { + my $self = shift; + + my $reset = $self->reset; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + + my $str = "$self->{+_ACTIVE_DISP}->[0] Events: $self->{+ECOUNT} ${cyan}$self->{+_ACTIVE_DISP}->[1]${reset}"; + + my $max = term_size() || 80; + + if (length($str) > $max) { + my $nocolor = $self->colorstrip($str); + $str = substr($nocolor, 0, $max - 8) . " ...)$reset" if length($nocolor) > $max; + $str =~ s/\(/$cyan(/; + $str =~ s/^\[[^\]]+\]/$self->{+_ACTIVE_DISP}->[0]/; + } + + return $str; +} + +sub render_buffered_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comp = $self->{+COMPOSER}->render_one_line($f) or return; + + return unless @$comp; + return [$self->build_line($tree, @$comp)]; +} + +sub render_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comps = $self->{+COMPOSER}->render_verbose($f); + + my (@parent, @times); + + if ($f->{parent}) { + @parent = $self->render_parent($f, $tree); + + if (@$comps && $comps->[-1]->[0] eq 'times') { + my $times = pop(@$comps); + @times = $self->build_line($tree, @$times); + } + } + + my @out; + + for my $comp (@$comps) { + my $ctree = $tree; + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + push @out => (@parent, @times); + + return \@out; +} + +sub render_quiet { + my $self = shift; + my ($f, $tree) = @_; + + my @out; + + my $comps = $self->{+COMPOSER}->render_brief($f); + for my $comp (@$comps) { + my $ctree = $tree ||= $self->render_tree($f); + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + if ($f->{parent} && !$f->{amnesty}) { + push @out => $self->render_parent($f, $tree ||= $self->render_tree($f), quiet => 1); + } + + return \@out; +} + +sub reset { + my $self = shift; + return $self->{+COLOR} ? $self->{+COLOR}->{reset} : ''; +} + +sub job_color { + my $self = shift; + my ($id, $set) = @_; + return '' unless $self->{+JOB_COLORS}; + return $self->{+JOB_COLORS}->{used}->{$id} || '' unless $set; + return $self->{+JOB_COLORS}->{used}->{$id} ||= shift @{$self->{+JOB_COLORS}->{free}} || ''; +} + +sub render_tree { + my $self = shift; + my ($f, $char) = @_; + $char ||= '|'; + + my $job = ''; + if ($f->{harness} && $f->{harness}->{job_id}) { + my $id = $f->{harness}->{job_id}; + my $name = $self->{+JOB_NAMES}->{$id} //= "^" . $self->{+NONAME_COUNTER}; + + my ($color, $reset) = ('', ''); + if ($self->{+JOB_COLORS}) { + $color = $self->job_color($id, 'set'); + $reset = $self->reset; + } + + my $len = length($name) // 0; + if (!$self->{+JOB_LENGTH} || $len > $self->{+JOB_LENGTH}) { + $self->{+JOB_LENGTH} = $len; + } + else { + $len = $self->{+JOB_LENGTH}; + } + + $job = sprintf("%sjob %${len}s%s ", $color, $name, $reset || ''); + } + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + my @pipes = (' ', map $char, 1 .. $depth); + return join(' ' => $job, @pipes) . ' '; +} + +sub build_line { + my $self = shift; + my ($tree, $facet, $tag, $text) = @_; + + $tree ||= ''; + $tag ||= ''; + $text ||= ''; + chomp($text); + + substr($tree, -2, 1, '+') if $facet eq 'assert'; + + $tag = substr($tag, 0 - TAG_WIDTH, TAG_WIDTH) if length($tag) > TAG_WIDTH; + + my $max = $self->{+TTY} && !$self->{+NO_WRAP} ? (term_size() || 80) : undef; + my $color = $self->{+COLOR}; + my $reset = $self->reset; + my $tcolor = $color ? $color->{TAGS}->{$tag} || $color->{FACETS}->{$facet} || '' : ''; + + my ($ps, $pe) = @{$FACET_TAG_BORDERS{$facet} || $FACET_TAG_BORDERS{default}}; + + $tag = uc($tag); + my $length = length($tag); + if ($length > TAG_WIDTH) { + $tag = substr($tag, 0, TAG_WIDTH); + } + elsif($length < TAG_WIDTH) { + my $pad = (TAG_WIDTH - $length) / 2; + my $padl = $pad + (TAG_WIDTH - $length) % 2; + $tag = (' ' x $padl) . $tag . (' ' x $pad); + } + + my $start; + if ($color) { + my $border = $color->{tag_border} || ''; + $start = "${reset}${border}${ps}${reset}${tcolor}${tag}${reset}${border}${pe}${reset}"; + } + else { + $start = "${ps}${tag}${pe}"; + } + $start .= " "; + + if ($tree) { + if ($color) { + my $trcolor = $color->{tree} || ''; + $start .= $trcolor . $tree . $reset; + } + else { + $start .= $tree; + } + } + + my @lines = split /[\r\n]/, $text; + @lines = ($text) unless @lines; + + my @out; + for my $line (@lines) { + if(@lines > 1 && $max && length("$ps$tag$pe $tree$line") > $max) { + @out = (); + last; + } + + if ($color) { + push @out => "${start}${tcolor}${line}$reset"; + } + else { + push @out => "${start}${line}"; + } + } + + return @out if @out; + + return ( + "$start----- START -----", + $text, + "$start------ END ------", + ) unless $color; + + my $blob = $color->{blob} || ''; + return ( + "$start${blob}----- START -----$reset", + "${tcolor}${text}${reset}", + "$start${blob}------ END ------$reset", + ); +} + +sub render_parent { + my $self = shift; + my ($f, $tree, %params) = @_; + + my $meth = $params{quiet} ? 'render_quiet' : 'render_event'; + + my @out; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness} ||= $f->{harness}; + my $tree = $self->render_tree($sf); + push @out => @{$self->$meth($sf, $tree)}; + } + + return unless @out; + + push @out => ( + $self->build_line("$tree^", 'parent', '', ''), + ); + + return @out; +} + + +sub DESTROY { + my $self = shift; + + my $io = $self->{+IO} or return; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + print $io Term::ANSIColor::color('reset') + if USE_ANSI_COLOR; + + print $io "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2 - An alternative to TAP, used by Test2::Harness. + +=head1 DESCRIPTION + +This formatter is the primary formatter used for final result rendering when +you use Test2::Harness. This formatter is NOT designed to have its output +consumed by code/machine/harnesses. The goal of this formatter is to have +output that is easily read by humans. + +=head1 SYNOPSIS + +If you are running a test directly with perl and want to use this formatter: + + $ perl -MTest2::Formatter::Test2 path/to/test.t + +You could also use the module directly in your test, but that is not +recommended as your test would then be unable to be run via prove or other +harnesses. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Formatter/Test2/Composer.pm b/lib2.0/Test2/Formatter/Test2/Composer.pm new file mode 100644 index 000000000..d6b642d19 --- /dev/null +++ b/lib2.0/Test2/Formatter/Test2/Composer.pm @@ -0,0 +1,507 @@ +package Test2::Formatter::Test2::Composer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use List::Util qw/first/; + +sub new { + my $class = shift; + return bless({}, $class); +} + +sub render_one_line { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + return [$f->{render}->[0]->{facet}, uc($f->{render}->[0]->{tag}), $f->{render}->[0]->{details}] + if $f->{render} && @{$f->{render}}; + + return (($class->halt($f))[0]) if $class->{control} && defined $class->{control}->{halt}; + + for my $type (qw/assert errors plan info times about/) { + next unless $f->{$type}; + my $m = "render_$type"; + my ($out) = $class->$m($f); + return $out if defined $out; + } + + return; +} + +sub render_verbose { + my $class = shift; + my ($in, %params) = @_; + + my $f = blessed($in) ? $in->facet_data : $in; + + return [map {[$_->{facet}, uc($_->{tag}), $_->{details}]} @{$f->{render}}] + if $f->{render} && @{$f->{render}}; + + my @out; + + push @out => $class->render_control($f, %params) if $f->{control}; + push @out => $class->render_plan($f) if $f->{plan}; + + if ($f->{assert}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{pass} || $f->{assert}->{no_debug}; + push @out => $class->render_amnesty($f) if $f->{amnesty} && @{$f->{amnesty}}; + } + + push @out => $class->render_info($f) if $f->{info}; + push @out => $class->render_errors($f) if $f->{errors}; + + push @out => $class->render_about($f) + if $f->{about} && !(@out || first { $f->{$_} } qw/stop plan info nest assert/); + + return \@out; +} + +sub render_super_verbose { + my $class = shift; + my ($in) = @_; + + my $out = $class->render_verbose($in, super_verbose => 1); + + my $f = blessed($in) ? $in->facet_data : $in; + + push @$out => $class->render_launch($f) if $f->{harness_job_launch}; + push @$out => $class->render_start($f) if $f->{harness_job_start}; + push @$out => $class->render_exit($f) if $f->{harness_job_exit}; + push @$out => $class->render_end($f) if $f->{harness_job_end}; + + unless (@$out) { + my ($name, $fallback); + for my $k (sort keys %$f) { + my $v = $f->{$k}; + + # Fallback should be longest harness* facet name + $fallback = $k if $k =~ m/harness/ && (!$fallback || length($fallback) < length($k)); + + my $list = ref($v) eq 'ARRAY' ? $v : [$v]; + for my $i (@$list) { + next unless ref($i); + last if $name = $i->{details}; + } + } + + $name //= $fallback // join ', ' => sort keys %$f; + + push @$out => ['harness', 'HARNESS', $name]; + } + + return $out; +} + +sub render_launch { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', 'Job Launched at ' . $f->{harness_job_launch}->{stamp}]; +} + +sub render_start { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_start}->{details}]; +} + +sub render_exit { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_exit}->{details}]; +} + +sub render_end { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', "Job completed at " . $f->{harness_job_end}->{stamp}]; +} + +sub render_control { + my $class = shift; + my ($f, %params) = @_; + + my @out; + + push @out => ['control', 'HALT', $f->{control}->{details}] + if defined $f->{control}->{halt}; + + return @out unless $params{super_verbose}; + + push @out => ['control', 'ENCODING', $f->{control}->{encoding}] + if $f->{control}->{encoding}; + + return @out if @out; + + return ['control', 'CONTROL', $f->{control}->{details}] + if defined $f->{control}->{details}; + + return; +} + +my %SHOW_BRIEF_TAGS = ( + 'CRITICAL' => 1, + 'DEBUG' => 1, + 'DIAG' => 1, + 'ERROR' => 1, + 'FAIL' => 1, + 'FAILED' => 1, + 'FATAL' => 1, + 'HALT' => 1, + 'PASSED' => 1, + 'REASON' => 1, + 'STDERR' => 1, + 'TIMEOUT' => 1, + 'WARN' => 1, + 'WARNING' => 1, + 'KILL' => 1, + 'SKIPPED' => 1, +); + +my %SHOW_BRIEF_FACETS = ( + control => 1, + error => 1, + trace => 1, +); + +sub render_brief { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + if ($f->{render} && @{$f->{render}}) { + my @show = grep { $SHOW_BRIEF_TAGS{uc($_->{tag})} || $SHOW_BRIEF_FACETS{lc($_->{facet})} } @{$f->{render}}; + return [map { [$_->{facet}, uc($_->{tag}), $_->{details}] } @show]; + } + + my @out; + + push @out => $class->render_control($f) if $f->{control}; + + if ($f->{assert} && !$f->{assert}->{pass} && !$f->{amnesty}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{no_debug}; + } + + if ($f->{info}) { + my $if = {%$f, info => [grep { $_->{debug} || $_->{important} } @{$f->{info}}]}; + push @out => $class->render_info($if) if @{$if->{info}}; + } + + push @out => $class->render_errors($f) if $f->{errors}; + + return \@out; +} + +sub render_plan { + my $class = shift; + my ($f) = @_; + + my $plan = $f->{plan}; + return ['plan', 'NO PLAN', $f->{plan}->{details}] if $plan->{none}; + + if ($plan->{skip}) { + return ['plan', 'SKIP ALL', $f->{plan}->{details}] + if $f->{plan}->{details}; + + return ['plan', 'SKIP ALL', "No reason given"]; + } + + return ['plan', 'PLAN', "Expected assertions: $f->{plan}->{count}"]; +} + +sub render_assert { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details} || '<UNNAMED ASSERTION>'; + + return ['assert', '! PASS !', $name] + if $f->{amnesty} && @{$f->{amnesty}}; + + return ['assert', 'PASS', $name] + if $f->{assert}->{pass}; + + return ['assert', 'FAIL', $name] +} + +sub render_amnesty { + my $class = shift; + my ($f) = @_; + + my %seen; + return map { + $seen{join '' => @{$_}{qw/tag details/}}++ + ? () + : ['amnesty', $_->{tag}, $_->{details}] + } @{$f->{amnesty}}; +} + +sub render_debug { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug; + if ($trace) { + $debug = $trace->{details}; + if(!$debug && $trace->{frame}) { + my $frame = $trace->{frame}; + $debug = "$frame->[1] line $frame->[2]"; + } + } + + $debug ||= "[No trace info available]"; + + chomp($debug); + + return ['trace', 'DEBUG', $debug]; +} + +sub render_info { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details} // ''; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + ['info', $_->{tag}, $details, $_->{table} || ()] + } @{$f->{info}}; +} + +sub render_about { + my $class = shift; + my ($f) = @_; + + return if $f->{about}->{no_display}; + return unless $f->{about} && $f->{about}->{details}; + + my $type; + if ($f->{about}->{package}) { + my $type = $f->{about}->{package}; + $type =~ s/^.*:://; + } + $type //= 'ABOUT'; + + return ['about', $type, $f->{about}->{details}]; +} + +sub render_errors { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + my $tag = $_->{tag} || ($_->{fail} ? 'FATAL' : 'ERROR'); + + ['error', $tag, $details] + } @{$f->{errors}}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2::Composer - Compose output components from event facets + +=head1 DESCRIPTION + +This is used by L<Test2::Formatter::Test2> to turn events into output +components. This logic lives here instead of in the formatter because it is +also used by L<Test2::Harness::UI>. Other tools may also find this conversion +useful. + +=head1 SYNOPSIS + + use Test2::Formatter::Test2::Composer; + + # Note, all methods are class methods, this is just here for convenience. + my $comp = Test2::Formatter::Test2::Composer->new(); + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + ... + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=head1 METHODS + +All methods are class methods, but they also work just fine on a blessed +instance. There is no benefit to a blessed instance, but you can create one for +convenience if it makes you more comfortable. + +=over 4 + +=item $inst = $class->new() + +Create a blessed instance. This is here for convenience only. All methods are +class methods. + +=item $arrayref = $class->render_one_line($event) + +=item $arrayref = $class->render_one_line(\%facet_data) + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + +This will return a single line of output from the event, even if the event +would normally return multiple lines. + +In order of priority: + +=over 4 + +=item Custom 'render' facet + +=item Control 'halt' facet (bail-out) + +=item Assertion (pass/fail) + +=item Error message + +=item Plan + +=item Info (note/diag) + +=item Timing data + +=item About + +=back + +=item @lines = $class->render_verbose($event, %control_params) + +=item @lines = $class->render_verbose(\%facet_data, %control_params) + +This will verbosely render any event. The C<%control_params> are passed +directly to C<render_control()> and are not used for anything else. + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=item @lines = $class->render_super_verbose($event) + +=item @lines = $class->render_super_verbose(\%facet_data) + +This is even more verbose than C<render_verbose()> because it produces output +lines even for facets that should normally not be seen, things that would +usually be considered noise. + +This is mainly useful for tools that allow deep inspection of log files. + +=back + +=head2 FACET RENDERERS + +With exception of C<render_control()> these are all the same. These all take +C<\%facet_data> as their only argument, and return a list of line-arrayrefs +C<[$facet, $tag, $text_for_humans]>. + +=over 4 + +=item @lines = $class->render_control(\%facet_data, super_verbose => $bool) + +This specific one is special in that it can take an extra argument. This +argument is used to toggle between super_verbose and regular verbosity. No +other facet renderer needs this toggle. If omitted it defaults to not being +super verbose. + +=item @lines = $class->render_launch(\%facet_data) + +=item @lines = $class->render_start(\%facet_data) + +=item @lines = $class->render_exit(\%facet_data) + +=item @lines = $class->render_end(\%facet_data) + +=item @lines = $class->render_brief(\%facet_data) + +=item @lines = $class->render_plan(\%facet_data) + +=item @lines = $class->render_assert(\%facet_data) + +=item @lines = $class->render_amnesty(\%facet_data) + +=item @lines = $class->render_debug(\%facet_data) + +=item @lines = $class->render_info(\%facet_data) + +=item @lines = $class->render_about(\%facet_data) + +=item @lines = $class->render_errors(\%facet_data) + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness.pm b/lib2.0/Test2/Harness.pm new file mode 100644 index 000000000..9d2ab358e --- /dev/null +++ b/lib2.0/Test2/Harness.pm @@ -0,0 +1,833 @@ +package Test2::Harness; +use strict; +use warnings; + +use File::Spec(); + +use POSIX ":sys_wait_h"; +use Carp qw/croak confess/; +use File::Path qw/remove_tree/; +use Time::HiRes qw/sleep/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::IPC qw/pid_is_running/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::File::JSONL(); + +use Test2::Harness::Aggregator(); + +use parent 'IPC::StateFile'; +use Test2::Harness::Util::HashBase; + +my %OBJECT_MAP = ( + scheduler => {depth => 0, rpc => 1, process => 1}, + runner => {depth => 1, rpc => 1, process => 1}, + resource => {depth => 1, rpc => 1, process => 1}, + aggregator => {depth => 1, rpc => 1, process => 1}, + task => {depth => 2, rpc => 1, process => 1}, + run => {depth => 1, rpc => 1, process => 0}, + + tmpdir => {depth => 0, shared => 1}, + workdir => {depth => 0, shared => 1}, + dummy => {depth => 0, shared => 1}, + project => {depth => 0, shared => 1}, + procname_prefix => {depth => 0, shared => 1}, + keep_dirs => {depth => 0, shared => 1}, + complete => {depth => 0, shared => 1}, + aborted => {depth => 0, shared => 1}, +); + +sub object_map { \%OBJECT_MAP } + +sub create_check { + my $self = shift; + + $self->txn(w => sub { + croak "'tmpdir' is a required attribute" unless $self->get_field('tmpdir'); + croak "'workdir' is a required attribute" unless $state->get_field('workdir'); + }); +} + +sub create { + my $class = shift; + my ($state_file, %data) = @_; + + die <<" EOT" if -e $state_file; +State file already exists, cannot create a new instance of $class. + +State file: $state_file + +You may want to use tools such as `yath clean`, `yath status` or `yath kill` to +check for running instances, and if necessary terminate them properly. + + EOT + + return $class->new( + $state_file, + data => { + pidmap => {}, + %data, + }, + ); +} + +sub connect { + my $class = shift; + my ($state_file, $meta, @bad) = @_; + + croak 'Too many arguments to connect($state_file, \%meta). Also got (' . join(', ', @bad) . ')' + if @bad; + + croak "The second argument to connect() needs to be a meta hash if present" + if $meta && !(ref($meta) && ref($meta) eq 'HASH'); + + die <<" EOT" unless -e $state_file; +State file does not exist, cannot connect to instance of $class. + +State file: $state_file + +You may need to use a tool such as `yath start` to create an instance. + + EOT + + return $class->new($state_file, meta => $meta); +} + +sub become_primary_proc_manager { + my $self = shift; + my %params = @_; + + my $callback = $params{callback}; + my $termination_hooks = $params{termination_hooks} // []; + + warn "FIXME need to make sure there are no other primary proc watchers"; + + my $pid = $$; + my $handler = sub { + my ($sig) = @_; + + $self->kill_all($sig) if $pid == $$; + $SIG{$sig} = 'DEFAULT'; + + kill($sig => $$); + }; + + # Intercept signals and forward them to all processes. + $SIG{TERM} = sub { $handler->('TERM') }; + $SIG{INT} = sub { $handler->('INT') }; + + my $ok = eval { $callback->(); 1 }; + my $err = $@; + + warn "\n*** Error encountered, shutting down yath ***\n$err" unless $ok; + + $self->finalize(); + $self->kill_all('TERM'); + $self->wait_all(); + + eval { + $self->$_() for @$termination_hooks; + $self->clean_workdir; + 1; + } or warn $@; + + die $err unless $ok; + + return 0; +} + +sub finalize { + my $self = shift; + + return if $self->complete; + + $self->transaction(w => sub { $self->data->{complete} = 1 }); + + $_->writer->write_message('TERMINATE') for @{$self->shared_all('aggregator')}; + + return; +} + +sub kill_all { + my $self = shift; + my ($sig) = @_; + + $sig //= 'TERM'; + + my %seen; + + for my $obj (@{$self->shared_all()}) { + my $pid = $obj->pid or next; + next if $pid == $$; + next if $seen{$pid}++; + + $obj->kill($sig); + } +} + +sub wait_ready { + my $self = shift; + $self->_wait(@_, blocking => 0); +} + +sub wait_all { + my $self = shift; + $self->_wait(@_, blocking => 1); +} + +sub _wait { + my $self = shift; + my %params = @_; + + my $do = $params{blocking} ? sub { wait() } : sub { waitpid(-1, WNOHANG) }; + + my %exits; + + my $subset; + if ($subset = $params{subset}) { + $subset = { map {$_ => 1} @$subset }; + } + + local $?; + while (my $pid = $do->()) { + my $exit = $?; + last if $pid < 0; + + $exits{$pid} = $exit; + + if ($subset) { + delete $subset->{$pid}; + last unless first { $_ } values %$subset; + } + } + + $self->transaction( + w => sub { + for my $obj (@{$self->shared_all()}) { + for my $meth (qw/pid cpid/) { + my $pid = $obj->$meth or next; + next unless exists $exits{$pid}; + + $obj->set_exit_code($exits{$pid}); + $exits{$pid} = $obj; + } + } + } + ); + + return \%exits; +} + +sub clean_workdir { + my $self = shift; + if ($self->keep_dirs) { + print "\n\nKeeping work directory '" . $self->workdir . "' as requested\n\n"; + return; + } + remove_tree($self->workdir, {safe => 1, keep_root => 0}); +} + + +1; + +__END__ + + +sub rundir { + my $self = shift; + my ($run_id) = @_; + return File::Spec->catdir($self->workdir, $run_id); +} + + +sub become_runner { confess "'become_runner' is not implemented, please subclass ${ \__PACKAGE__ } to provide an implementation." } + +sub set_test_params { + my $self = shift; + my %params = @_; + + $self->transaction(w => sub { $self->data->{test_params} = \%params }); +} + +sub get_test_params { shift->transaction(r => sub { +{ %{shift->data->{test_params}} } }) } + +sub spawn { + my $self = shift; + my ($type, %args) = @_; + + die "\n\n====\nRefusing to spawn '$type', test run aborted:\n" . join("\n" => @{$self->aborted}) . "\n====\n\n" + if $self->aborted && @{$self->aborted}; + + croak "Cannot spawn ($type) from a read-only connection" + if $self->read_only; + + my $become = $args{become} // "become_${type}"; + croak "Not sure how to spawn a '$type', '$become()' is not defined" unless $self->can($become) || ref($become) eq 'CODE'; + + my $pid = fork // die "Could not fork: $!"; + return $self->record_pid($$, $pid, $type) if $pid; + + $0 = $args{proc_name} || "$0-$type"; + + if (my $collector = delete $args{collector}) { + $collector->setup_child(); + } + + $SIG{TERM} = 'DEFAULT'; + $SIG{INT} = 'DEFAULT'; + + unless(eval { exit($self->$become(%args)); 1 }) { + warn($@); + exit(255); + } + + confess("Escaped scope after spawned call to '$become()'"); + exit(255); +} + +sub spawn_collected { + my $self = shift; + my ($type, %params) = @_; + + $params{proc_name} //= "$0-collector"; + + $params{child_params} //= {}; + $params{child_params}->{type} //= $type; + $params{child_params}->{name} //= $type; + + return $self->spawn("collector" => %params); +} + +sub spawn_aggregator { + my $self = shift; + return $self->spawn('aggregator' => @_); +} + +sub become_aggregator { + my $self = shift; + my (%params) = @_; + + my $name = $params{name}; + + $0 .= "-$name"; + + croak "There is already an aggregator for '$name'" + if $self->aggregators->{$name}; + + my $dir = $self->workdir; + + my $output_file = File::Spec->catfile($dir, "$name.jsonl"); + my $fifo_file = File::Spec->catfile($dir, "$name.fifo"); + + $self->transaction(w => sub { + $self->aggregators->{$name} = { + pid => $$, + output_file => $output_file, + fifo_file => $fifo_file, + }; + }); + + my $aggregator = Test2::Harness::Aggregator->new( + name => $name, + fifo_file => $fifo_file, + output_file => $output_file, + ); + + return $aggregator->run(); +} + +sub clear_pid { + my $self = shift; + my ($pid) = @_; + + $self->transaction( + w => sub { + my $pidmap = $self->pidmap; + + my $entry = delete $pidmap->{$pid}; + + if (my $parent = $entry->{parent}) { + delete $pidmap->{$parent}->{children}->{$pid}; + } + + if (my $type = $entry->{type}) { + delete $pidmap->{$type}->{$pid}; + } + } + ); +} + +sub record_pid { + my $self = shift; + my ($parent, $pid, $type) = @_; + + # Do not allow types that can conflict with pids. + croak "Type may not be a number" if $type =~ m/^-?\d+$/; + + $self->transaction( + w => sub { + my $pidmap = $self->pidmap; + + $pidmap->{$pid} = {parent => $parent, children => {}, type => $type}; + + $pidmap->{$parent}->{children}->{$pid} = $pid; + + $pidmap->{$type}->{$pid} = $pid if $type; + } + ); + + return $pid; +} + +sub check_runner { + my $self = shift; + + my $runners = $self->transaction(r => sub { + return 0 unless $self->runner; + + $self->pidmap->{runner}; + }); + + return 0 unless $runners; + + +} + +sub children { grep { m/^-?\d+$/ } keys %{ $_[0]->pidmap->{$$}->{children} //= {} } } + +sub kill_children { + my $self = shift; + my ($sig) = @_; + $sig //= 'TERM'; + + kill($sig, $self->children); +} + +sub kill_all { + my $self = shift; + my ($sig) = @_; + + $sig //= 'TERM'; + + my $pidmap = $self->pidmap; + + my %seen; + + my @pids = keys %$pidmap; + while (@pids) { + my $pid = shift @pids; + next unless $pid =~ m/^-?\d+$/; + next if $pid == $$; + + $seen{$pid} //= 0; + next if $seen{$pid} > 1; + + if ($seen{$pid} < 1) { + $seen{$pid} = 1; + + my @add = keys %{ $pidmap->{$pid}->{children} // {} }; + + if (@add) { + unshift @pids => (@add, $pid); + next; + } + } + + next if $seen{$pid} > 1; + $seen{$pid} = 2; + + kill($sig, $pid); + } +} + +sub wait_all { + my $self = shift; + + while (my $pid = wait()) { + last if $pid < 0; + $self->clear_pid($pid); + } +} + +sub clean_workdir { + my $self = shift; + if ($self->keep_dirs) { + print "\n\nKeeping work directory '" . $self->workdir . "' as requested\n\n"; + return; + } + remove_tree($self->workdir, {safe => 1, keep_root => 0}); +} + +sub abort { + my $self = shift; + my ($reason) = @_; + $self->transaction(w => sub { push @{$self->data->{aborted} //= []} => $reason }); + warn $reason; + exit 255; +} + +sub resource { + my $self = shift; + my ($class, $args) = @_; + + require(mod2file($class)); + + if ($args) { + $self->transaction(w => sub { + confess "Resource '$class' already initialized" if $self->data->{resources}->{$class}; + $self->data->{resources}->{$class} = $class->new(@$args, state => $self, state_field => [resources => $class]); + }); + } + + $self->transaction(r => sub { + my $res = $self->data->{resources}->{$class} or confess "No resource '$class'"; + return $class->from_data($res, $self, [resources => $class]); + }); +} + +sub resources { + my $self = shift; + + my @out; + + $self->transaction(r => sub { + for my $class (keys %{$self->data->{resources} // {}}) { + require(mod2file($class)); + my $data = $self->data->{resources}->{$class} or confess "No resource '$class'"; + my $res = $class->from_data($data, $self, [resources => $class]); + push @out => $res; + } + }); + + # Job limiter first, followed by apply to all, then alphabetical by class + return sort { $b->is_job_limiter <=> $a->is_job_limiter || $b->applies_to_all_tests <=> $a->applies_to_all_tests || ref($a) cmp ref($b) } @out; +} + +1; + +__END__ + +sub is_job_limiter { 0 } +sub applies_to_all_tests { 0 } +sub applies_to_test { 0 } +sub available { 0 } +sub available_for_test { 0 } +sub allocate_for_test { croak "Not Implemented" } +sub release_for_test { croak "Not Implemented" } + + +sub init { + my $workdir = $params{+WORKDIR}; + my $state_file = $params{+STATE_FILE}; + my $state = $params{+STATE}; + + my $self = bless(\%params, $class); + + croak "You must specify either a 'state', 'workdir' or a 'state_file'" + unless $workdir || $state_file || $state; + + $state_file = $self->{+STATE_FILE} //= clean_path( + $state ? $state->state_file : File::Spec->catfile($workdir, 'state.json'), + ); + + $state = $self->{+STATE} //= Test2::Harness::State->new( + state_file => $state_file, + workdir => $workdir, + ); + + $workdir //= $state->workdir; + + croak "Invalid state" unless $state; + croak "Invalid work dir '$workdir'" unless -d $workdir; + croak "Invalid state file '$state_file'" unless -e $state_file; + + return $self; +} + +sub connect { + +} + +sub create { + my $class = shift; + + my $workdir = $settings->workspace->workdir; + croak "Invalid work dir '$workdir'" unless -d $workdir; + + my $state_file = File::Spec->catfile($workdir, 'state.json'); + my $state = Test2::Harness::State->new( + workdir => $workdir, + state_file => $state_file, + ); + + $state->init_state(settings => $settings); + + return bless( + { + workdir => $workdir, + state_file => $state_file, + state => $state, + }, + $class, + ); +} + +1; + +__END__ +sub settings { + my $self = shift; + + $self->state->transaction(r => sub { + my $data = $_[1]->settings or return; + return Test2::Harness::Settings->new(%$data); + }); +} + +sub start_aggregator { + my $self = shift; + my ($run_id, $name, %params) = @_; + + croak "Cannot start an aggregator from an observer" if $self->{+OBSERVER}; + + croak "There is already an aggregator named '$name' for run id '$run_id'" + if $self->check_aggregator($run_id, $name); + + my $state = $self->state; + my $rundir = $self->rundir; + + my $output_file = File::Spec->catfile($rundir, "$name.json"); + my $fifo_file = File::Spec->catfile($rundir, "$name.fifo"); + + my $aggregator = Test2::Harness::Aggregator->new( + name => $name, + state => $state, + run_id => $run_id, + fifo_file => $fifo_file, + output_file => $output_file, + ); + + my ($pid, $ppid); + + my $run_aggregator = sub { + my $res; + eval { $res = $aggregator->run($ppid) } or warn $@; + exit($res // 255); + }; + + my $add_aggregator = sub { + my $entry = { + pid => $pid, + name => $name, + fifo => $fifo_file, + run_id => $run_id, + parent => $ppid, + output => $output_file, + }; + + my $pid_entry = { + pid => $pid, + name => $name, + type => 'aggregator', + parent => $ppid, + run_id => $run_id, + }; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + $data->aggregators->{$run_id}->{$name} = $entry; + $data->processes->{$pid} = $pid_entry; + $data->processes->{$ppid}->{children}->{$pid} = $pid; + } + ); + + return $entry; + }; + + if ($ppid = $params{ppid} || $params{parent_pid}) { + $pid = $$; + eval { + $add_aggregator->(); + $run_aggregator->(); + 1; + } or warn $@; + exit(255); + } + + $ppid = $$; + $pid = fork // die "Could not fork: $!"; + + # Parent: + return $add_aggregator->() if $pid; + + $run_aggregator->(); +} + +sub aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + my $pid = $self->check_aggregator($run_id, $name); + return $pid if $pid; + croak "No aggregator named '$name' for run id '$run_id'"; +} + +sub aggregators { + my $self = shift; + + my @out; + + $self->{+STATE}->transaction(r => sub { + my ($state, $data) = @_; + @out = values %{$data->aggregators // {}}; + }); + + return grep { $self->_check_aggregator($_) } @out; +} + +sub check_aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + my $entry; + $self->{+STATE}->transaction(r => sub { + my ($state, $data) = @_; + $entry = $data->aggregators->{$run_id}->{$name}; + }); + + return undef unless $entry; + + return $self->_check_aggregator($entry); +} + +sub _check_aggregator { + my $self = shift; + my ($entry) = @_; + + my $have_fifo = -p $entry->{fifo}; + my $have_proc = pid_is_running($entry->{pid}); + + return $entry if $have_fifo && $have_proc; + return undef if $have_proc; + + # Do not modify state from an observer + return undef if $self->{+OBSERVER}; + + # No proc means we need to clear it. We may or may not have a fifo to clean + # up. If we have a proc and no fifo though it could be that the proc is + # still starting. + + my $pid = $entry->{pid}; + my $name = $entry->{name}; + my $fifo = $entry->{fifo}; + my $run_id = $entry->{run_id}; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + delete $data->aggregators->{$run_id}->{$name}; + + my $pentry = delete $data->processes->{$pid}; + + delete $data->processes->{$pentry->{parent}}->{children}->{$pid} + if $pentry->{parent}; + + return unless -e $fifo; + unlink($fifo) or warn "Failed to delete fifo '$fifo': $!"; + }, + ); + + return undef; +} + +sub stop_aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + croak "Cannot stop an aggregator from an observer" if $self->{+OBSERVER}; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + return if $data->aggregators->{$run_id}->{$name}->{stopped}; + $data->aggregators->{$run_id}->{$name}->{stopped} = 1; + + $fifo = Atomic::Pipe->write_fifo($entry->{fifo}); + $fifo->write_message("TERMINATE"); + $fifo->close(); + }, + ); + + return; +} + +sub kill_aggregator { + my $self = shift; + my ($run_id, $name, $sig) = @_; + + croak "Cannot kill an aggregator from an observer" if $self->{+OBSERVER}; + + my ($entry, $out); + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + $entry = $data->aggregators->{$run_id}->{$name}; + return undef unless $entry; + + $out = kill($sig, $entry->{pid}); + }, + ); + + return $out if $entry; + croak "Invalid aggregator ($run_id, $name)"; +} + +1; + +__END__ +sub init { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + elsif($settings) { + + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + + + $self->SUPER::init(); +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[1]->settings}) }); +} + + + +1; diff --git a/lib2.0/Test2/Harness/Aggregator.pm b/lib2.0/Test2/Harness/Aggregator.pm new file mode 100644 index 000000000..66e8a7314 --- /dev/null +++ b/lib2.0/Test2/Harness/Aggregator.pm @@ -0,0 +1,156 @@ +package Test2::Harness::Aggregator; +use strict; +use warnings; + +use Carp qw/croak/; +use POSIX qw/mkfifo/; +use Time::HiRes qw/time sleep/; + +use Test2::Harness::Util::JSON qw/encode_json/; + +use IO::Handle; +use Atomic::Pipe; +use Test2::Harness::Util::File::Stream; + +our $VERSION = '2.000000'; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + <fifo_file + <output_file + <name +}; + +sub init { + my $self = shift; + + unless ($self->{+FIFO_FILE} && $self->{+OUTPUT_FILE}) { + my $name = $self->{+NAME} or croak "Must provide the 'name' attribute, or both the 'fifo_file' and 'output_file' attributes"; + my $dir = $self->state->workdir; + $self->{+OUTPUT_FILE} //= File::Spec->catfile($dir, "$name.jsonl"); + $self->{+FIFO_FILE} //= File::Spec->catfile($dir, "$name.fifo"); + } +} + +sub proc_name { + my $self = shift; + my $base = $self->SUPER::proc_name(); + return "${base}-$self->{+NAME}" if $self->{+NAME}; + return $base; +} + +sub writer { + my $self = shift; + + my $iter = 0; + while (1) { + sleep 0.1 if $iter++; + last if $iter > 20; + + my $file = $self->fifo_file; + next unless -p $file; + + my $fifo = Atomic::Pipe->write_fifo($file); + $fifo->resize($fifo->max_size); + + return $fifo; + } + + croak "Timeout waiting for FIFO"; +} + +sub run { + my $self = shift; + + my $sig = 0; + my $fifo; + + local $SIG{INT} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGINT\n"; + $sig = 'INT'; + $fifo->blocking(0) if $fifo; + }; + + local $SIG{TERM} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGTERM\n"; + $sig = 'TERM'; + $fifo->blocking(0) if $fifo; + }; + + open(my $outfh, '>>', $self->{+OUTPUT_FILE}) or die "Could not open file: '$self->{+OUTPUT_FILE}': $!"; + $outfh->autoflush(1); + + my $ok = eval { + $SIG{__WARN__} = sub { + print STDERR @_; + $outfh->write(encode_json({ + facet_data => { + info => [ + {tag => 'AGG WARN', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + }; + + mkfifo($self->{+FIFO_FILE}, 0700) or die "Failed to create fifo ($self->{+FIFO_FILE}): $!"; + + $fifo = Atomic::Pipe->read_fifo($self->{+FIFO_FILE}); + $fifo->resize($fifo->max_size); + $fifo->blocking(0) if $sig; + + # Keep this loop as tight as possible + while (1) { + my $event = $fifo->read_message; + + # Conditional should be tight, but the codeblock only runs once at + # the end if there is a signal, so the block can be expensive. + if ($sig && !$event) { + my $json = encode_json({ + facet_data => { + info => [ + {tag => "AGG SIG", details => "(AGGREGATOR) got SIG${sig}"}, + ], + } + }); + + print $outfh $json, "\nnull\n"; + last; + } + + chomp($event); + + next if $event eq 'null'; + + if ($event eq 'TERMINATE') { + print $outfh "null\n"; + last; + } + + print $outfh $event, "\n"; + } + + 1; + }; + my $err = $@; + + $SIG{TERM} = 'DEFAULT'; + $SIG{INT} = 'DEFAULT'; + + if ($sig) { + $SIG{$sig} = 'DEFAULT'; + kill($sig, $$); + } + + return 0 if $ok; + + print STDERR $err; + $outfh->write(encode_json({ + facet_data => { + info => [ + {tag => 'AGG DIED', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + + return 255; +} diff --git a/lib2.0/Test2/Harness/Collector.pm b/lib2.0/Test2/Harness/Collector.pm new file mode 100644 index 000000000..3b19d861c --- /dev/null +++ b/lib2.0/Test2/Harness/Collector.pm @@ -0,0 +1,712 @@ +package Test2::Harness::Collector; +use strict; +use warnings; + +use Carp qw/croak cluck/; +use POSIX ":sys_wait_h"; +use Time::HiRes qw/time/; +use Scalar::Util qw/reftype/; + +use Test2::Harness::Util qw/parse_exit apply_encoding/; +use Test2::Harness::Util::IPC qw/swap_io/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use IO::Select; +use Scope::Guard; +use Atomic::Pipe; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + merge_outputs + env_vars + + <handles + + <end_callback + + <parser + <auditor + <output + <output_cb + + <run_id + <job_id + <job_try + + +clean + +buffer +}; + +sub init { + my $self = shift; + + croak "'parser' is a required attribute" + unless $self->{+PARSER}; + + croak "'output' is a required attribute" + unless $self->{+OUTPUT}; + + my $ref = ref($self->{+OUTPUT}); + + if ($ref eq 'CODE') { + $self->{+OUTPUT_CB} = $self->{+OUTPUT}; + } + elsif ($ref eq 'GLOB') { + my $fh = $self->{+OUTPUT}; + $self->{+OUTPUT_CB} = sub { print $fh @_ }; + } + elsif ($self->{+OUTPUT}->isa('Atomic::Pipe')) { + my $wp = $self->{+OUTPUT}; + $self->{+OUTPUT_CB} = sub { $wp->write_message(encode_json($_)) for @_ }; + } + else { + croak "Unknown output type: $self->{+OUTPUT} ($ref)"; + } + + $self->{+ENV_VARS} //= {}; + $self->{+RUN_ID} //= 0; + $self->{+JOB_ID} //= 0; + $self->{+JOB_TRY} //= 0; + $self->{+MERGE_OUTPUTS} //= 0; + + my ($out_r, $out_w) = Atomic::Pipe->pair(mixed_data_mode => 1); + my ($err_r, $err_w) = $self->{+MERGE_OUTPUTS} ? ($out_r, $out_w) : Atomic::Pipe->pair(mixed_data_mode => 1); + + $self->{+HANDLES} = { + out_r => $out_r, + out_w => $out_w, + err_r => $err_r, + err_w => $err_w, + }; +} + +sub _pre_event { + my $self = shift; + my (%data) = @_; + + $data{stamp} //= time; + + my @events = $self->{+PARSER}->parse_io(\%data); + @events = $self->{+AUDITOR}->audit(@events) if $self->{+AUDITOR}; + + $self->{+OUTPUT_CB}->(@events); + + return; +} + +sub _die { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + $self->_pre_event( + stream => 'process', + stamp => time, + event => { + facet_data => { + errors => [{tag => 'ERROR', details => $msg, fail => 1}], + trace => {frame => \@caller}, + }, + }, + ); + + exit(255); +} + +sub _warn { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + $self->_pre_event( + stream => 'process', + stamp => time, + event => { + facet_data => { + info => [{tag => 'WARNING', details => $msg, debug => 1}], + trace => {frame => \@caller} + }, + }, + ); +} + +sub setup_child { + my $self = shift; + + my $env = $self->env_vars; + + my $handles = $self->handles; + + delete($handles->{out_r})->close(); + delete($handles->{err_r})->close(); + + swap_io(\*STDOUT, $handles->{out_w}->wh, sub { $self->_die(@_) }); + swap_io(\*STDERR, $handles->{err_w}->wh, sub { $self->_die(@_) }); + + $ENV{T2_HARNESS_USE_ATOMIC_PIPE} = $self->{+MERGE_OUTPUTS} ? 1 : 2; + { + no warnings 'once'; + $Test2::Harness::STDOUT_APIPE = $handles->{out_w}; + $Test2::Harness::STDERR_APIPE = $handles->{err_w} unless $self->{+MERGE_OUTPUTS}; + } + + if ($env) { + $ENV{$_} = $env->{$_} for keys %$env; + } + + return; +} + +sub process { + my $self = shift; + my ($child_pid) = @_; + + delete($self->handles->{out_w})->close(); + delete($self->handles->{err_w})->close(); + + my $stamp = time; + $self->_pre_event( + stream => 'process', + stamp => $stamp, + action => 'launch', + launch => { stamp => $stamp, pid => $$ }, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + $SIG{INT} = sub { + $self->_warn("$$: Got SIGINT, forwarding to child process $child_pid.\n"); + kill('INT', $child_pid); + $SIG{INT} = 'DEFAULT'; + }; + $SIG{TERM} = sub { + $self->_warn("$$: Got SIGTERM, forwarding to child process $child_pid.\n"); + kill('TERM', $child_pid); + $SIG{TERM} = 'DEFAULT'; + }; + $SIG{PIPE} = 'IGNORE'; + + my $guard = Scope::Guard->new(sub { + eval { $self->_die("Scope Leak inside collector post-fork!") }; + exit(255); + }); + + unless (eval { $self->_process($child_pid); 1 }) { + my $err = $@; + + eval { $self->end_callback->($self) } if $self->end_callback->($self); + eval { $guard->dismiss() }; + eval { $self->_die($err) } or $self->_warn($@); + + exit(255); + } + + if ($self->end_callback) { + unless (eval { $self->end_callback->($self); 1 }) { + my $err = $@; + + $self->_pre_event( + stream => 'process', + stamp => time, + event => { + facet_data => { + errors => [{tag => 'ERROR', details => $err, fail => 1}], + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + eval { $guard->dismiss() }; + + exit(255); + } + } + + $guard->dismiss(); + + exit(0); +} + +sub _add_item { + my $self = shift; + my ($stream, $val) = @_; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + push @{$buffer->{$stream}} => [time, $val]; + + $self->_flush() unless keys(%$seen); + + return unless ref($val); + + my $event_id = $val->{event_id} or die "Event has no ID!"; + + my $count = ++($seen->{$event_id}); + return unless $count >= ($self->{+MERGE_OUTPUTS} ? 1 : 2); + + $self->_flush(to => $event_id); +} + +sub _flush { + my $self = shift; + my %params = @_; + + my $to = $params{to}; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + for my $stream (qw/stderr stdout/) { + while (1) { + my $set = shift(@{$buffer->{$stream}}) or last; + my ($stamp, $val) = @$set; + if (ref($val)) { + # Send the event, unless it came via STDERR in which case it should only be a hashref with an event_id + $self->_pre_event(stream => $stream, data => $val, stamp => $stamp) + unless $stream eq 'stderr'; + + last if $to && $val->{event_id} eq $to; + } + else { + $self->_pre_event(stream => $stream, line => $val, stamp => $stamp); + } + } + } +} + +sub _process { + my $self = shift; + my ($pid) = @_; + + $self->{+BUFFER} = {seen => {}, stderr => [], stdout => []}; + + my $stdout = $self->handles->{out_r}; + my $stderr = $self->handles->{err_r}; + + $stdout->blocking(0); + $stderr->blocking(0); + + my $ios = IO::Select->new; + + my %sets = ($stdout->rh => ['stdout', $stdout]); + $ios->add($stdout->rh); + + unless ($self->{+MERGE_OUTPUTS}) { + $sets{$stderr->rh} = ['stderr', $stderr]; + $ios->add($stderr->rh); + } + + local $SIG{CHLD} = sub { 1 }; + + my ($exited, $exit); + while (1) { + my $did_work = 0; + + unless ($exited) { + if (my $check = waitpid($pid, WNOHANG)) { + $exit = parse_exit($? // 0); + + if ($check == $pid) { + $exited = time; + $did_work++; + } + else { + die("waitpid returned $check"); + } + } + } + + my $enc; + + my @sets = $ios->can_read(); + + while (@sets) { + for my $io (@sets) { + my ($name, $fh) = @{$sets{$io}}; + + my ($type, $val) = $fh->get_line_burst_or_data; + unless ($type) { + @sets = grep { $_ ne $io } @sets; + next; + } + + $did_work++; + + if ($type eq 'message') { + my $decoded = decode_json($val); + $self->_add_item($name => $decoded); + } + elsif ($type eq 'line') { + chomp($val); + $self->_add_item($name => $val); + } + else { + chomp($val); + die("Invalid type '$type': $val"); + } + } + } + + next if $did_work; + last if $exited; + } + + $self->_flush(); + + $self->_pre_event( + stream => 'process', + stamp => $exited, + action => 'exit', + exit => {exit => $exit, stamp => $exited}, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + return; +} + + +__END__ +sub DESTROY { + my $self = shift; + + $self->cleanup_proc; + + return unless $self->{+CHILDREN}; + for my $pid (keys %{$self->{+CHILDREN}}) { + next unless $$ == $self->{+CHILDREN}->{$pid}; + cluck("Failed to reap children parent process $$ when collector instance was destroyed"); + return $self->reap; + } +} + +sub reap { + my $self = shift; + my (@pids) = @_; + + unless (@pids) { + @pids = grep {$$ == $self->{+CHILDREN}->{$_}} keys %{$self->{+CHILDREN} // {}}; + } + return unless @pids; + + my @out; + + for my $pid (@pids) { + croak "$pid is not owned by this collector" + unless $self->{+CHILDREN}->{$pid} && $$ == $self->{+CHILDREN}->{$pid}; + + delete $self->{+CHILDREN}->{$pid}; + + my $check = waitpid($pid, 0); + my $exit = parse_exit($? // 0); + if ($check == $pid) { + push @out => $exit; + warn "Collector exited with a non-zero status (ERR: $exit->{err}, SIG: $exit->{sig})" if $exit->{all}; + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + delete $data->processes->{$pid}; + } + ); + } + else { + die("waitpid returned $check"); + } + } + + return @out; +} + +sub run { + my $self = shift; + my %params = @_; + + my $name = $params{name} or croak "'name' is a required argument"; + my $type = $params{type} or croak "'type' is a required argument"; + my $launch_cb = $params{launch_cb} or croak "'launch_cb' is a required argument"; + my $env = $params{env}; + + my $parent = $params{parent_pid}; + + if (!$parent) { + $parent = $$; + my $collector_pid = fork // CORE::die("Could not fork: $!"); + + if ($collector_pid) { + $self->{+CHILDREN}->{$collector_pid} = $$; + return $collector_pid; + } + + } + + $0 = "Yath-Collector $name"; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$} = {type => 'collector', parent => $parent, pid => $$, name => $name}; + }); + + my ($out_r, $out_w) = Atomic::Pipe->pair(mixed_data_mode => 1); + my ($err_r, $err_w) = $self->{+MERGE_OUTPUTS} ? ($out_r, $out_w) : Atomic::Pipe->pair(mixed_data_mode => 1); + + my $child_pid = fork // CORE::die("Could not fork: $!"); + + if (!$child_pid) { + $0 = $name; + swap_io(\*STDOUT, $out_w->wh, sub { $self->_die(@_) }); + swap_io(\*STDERR, $err_w->wh, sub { $self->_die(@_) }); + + $ENV{T2_HARNESS_USE_ATOMIC_PIPE} = $self->{+MERGE_OUTPUTS} ? 1 : 2; + { + no warnings 'once'; + $Test2::Harness::STDOUT_APIPE = $out_w; + $Test2::Harness::STDERR_APIPE = $err_w unless $self->{+MERGE_OUTPUTS}; + } + + if ($env) { + $ENV{$_} = $env->{$_} for keys %$env; + } + + eval { $launch_cb->(); 1 } or $self->_die($@ // "launch exception"); + + $self->_die("launch-cb returned, it should not do that!"); + } + + $self->_die("Failed to launch child '$type': '$name'") unless $child_pid; + + $self->{+CHILDREN}->{$child_pid} = $$; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$}->{children}->{$child_pid} = $child_pid; + $data->processes->{$child_pid} = {type => $type, parent => $$, pid => $child_pid, name => $name}; + }); + + $self->_die("Did not get a PID from launch callback (Did callback fail to exit when done?)") + unless $child_pid; + + my $stamp = time; + $self->_pre_event( + stream => 'process', + stamp => $stamp, + action => 'launch', + launch => { stamp => $stamp, pid => $child_pid }, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + $SIG{INT} = sub { + $self->_warn("$$: Got SIGINT, forwarding to child process $child_pid.\n"); + kill('INT', $child_pid); + $SIG{INT} = 'DEFAULT'; + }; + $SIG{TERM} = sub { + $self->_warn("$$: Got SIGTERM, forwarding to child process $child_pid.\n"); + kill('TERM', $child_pid); + $SIG{TERM} = 'DEFAULT'; + }; + $SIG{PIPE} = 'IGNORE'; + + my $guard = Scope::Guard->new(sub { + eval { $self->_die("Scope Leak inside collector post-fork!") }; + exit(255); + }); + + $out_w->close; + $err_w->close; + + unless (eval { $self->_run(pid => $child_pid, stdout => $out_r, stderr => $err_r); 1 }) { + my $err = $@; + + $self->cleanup_proc; + + eval { + $guard->dismiss(); + $self->_die($err); + }; + + exit(255); + } + + $self->cleanup_proc; + $guard->dismiss(); + exit(0); +} + +sub cleanup_proc { + my $self = shift; + + return 1 if $self->{+CLEAN}; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$} if $data->processes->{$$} && $data->processes->{$$}->{type} eq 'collector'; + }); + + return $self->{+CLEAN} = 1; +} + +sub _run { + my $self = shift; + my %params = @_; + + $self->{+BUFFER} = {seen => {}, stderr => [], stdout => []}; + + my $pid = $params{pid}; + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + + $stdout->blocking(0); + $stderr->blocking(0); + + my $ios = IO::Select->new; + + my %sets = ($stdout->rh => ['stdout', $stdout]); + $ios->add($stdout->rh); + + unless ($self->{+MERGE_OUTPUTS}) { + $sets{$stderr->rh} = ['stderr', $stderr]; + $ios->add($stderr->rh); + } + + my ($exited, $exit); + while (1) { + my $did_work = 0; + + unless ($exited) { + if (my $check = waitpid($pid, WNOHANG)) { + $exit = parse_exit($? // 0); + + delete $self->{+CHILDREN}->{$pid}; + if ($check == $pid) { + $exited = time; + $did_work++; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$}->{children}->{$pid}; + delete $data->processes->{$pid}; + }); + } + else { + die("waitpid returned $check"); + } + } + } + + my $enc; + + my @sets = $ios->can_read(); + + while (@sets) { + for my $io (@sets) { + my ($name, $fh) = @{$sets{$io}}; + + my ($type, $val) = $fh->get_line_burst_or_data; + unless ($type) { + @sets = grep { $_ ne $io } @sets; + next; + } + + $did_work++; + + if ($type eq 'message') { + my $decoded = decode_json($val); + $self->_add_item($name => $decoded); + } + elsif ($type eq 'line') { + chomp($val); + $self->_add_item($name => $val); + } + else { + chomp($val); + die("Invalid type '$type': $val"); + } + } + } + + next if $did_work; + last if $exited; + } + + $self->_flush(); + + $self->_pre_event( + stream => 'process', + stamp => $exited, + action => 'exit', + exit => {exit => $exit, stamp => $exited}, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + return; +} + +sub _add_item { + my $self = shift; + my ($stream, $val) = @_; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + push @{$buffer->{$stream}} => [time, $val]; + + $self->_flush() unless keys(%$seen); + + return unless ref($val); + + my $event_id = $val->{event_id} or die "Event has no ID!"; + + my $count = ++($seen->{$event_id}); + return unless $count >= ($self->{+MERGE_OUTPUTS} ? 1 : 2); + + $self->_flush(to => $event_id); +} + +sub _flush { + my $self = shift; + my %params = @_; + + my $to = $params{to}; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + for my $stream (qw/stderr stdout/) { + while (1) { + my $set = shift(@{$buffer->{$stream}}) or last; + my ($stamp, $val) = @$set; + if (ref($val)) { + # Send the event, unless it came via STDERR in which case it should only be a hashref with an event_id + $self->_pre_event(stream => $stream, data => $val, stamp => $stamp) + unless $stream eq 'stderr'; + + last if $to && $val->{event_id} eq $to; + } + else { + $self->_pre_event(stream => $stream, line => $val, stamp => $stamp); + } + } + } +} + +1; diff --git a/lib2.0/Test2/Harness/Collector/Auditor.pm b/lib2.0/Test2/Harness/Collector/Auditor.pm new file mode 100644 index 000000000..5fedbdd97 --- /dev/null +++ b/lib2.0/Test2/Harness/Collector/Auditor.pm @@ -0,0 +1,576 @@ +package Test2::Harness::Collector::Auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use List::Util qw/first max/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::File::JSON; + +use Test2::Harness::Util qw/hub_truth parse_exit/; + +use Test2::Harness::Log::TimeTracker; + +use Test2::Harness::Event; + +use Test2::Harness::Util::HashBase qw{ + -file + -job_try + -summary_file <previous_summary + -state + -run_id + -job_id + + -assertion_count + -exit + -plan + +fail + -_errors + -_failures + -_sub_failures + -_plans + -nested + -subtests + -numbers + -times + -halt + -failed_subtest_tree +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" + unless defined $self->{+RUN_ID}; + + croak "'job_id' is a required attribute" + unless defined $self->{+JOB_ID}; + + croak "'job_try' is a required attribute" + unless defined $self->{+JOB_TRY}; + + croak "'file' is a required attribute" + unless defined $self->{+FILE}; + + $self->{+_FAILURES} = 0; + $self->{+_ERRORS} = 0; + $self->{+ASSERTION_COUNT} = 0; + + $self->{+NUMBERS} = {}; + $self->{+TIMES} = Test2::Harness::Log::TimeTracker->new(); + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; +} + +sub pass { !$_[0]->fail } +sub fail { + my $self = shift; + return $self->{+FAIL} if $self->{+FAIL}; + return $self->{+FAIL} = 1 if $self->fail_error_facet_list; + return 0; +} + +sub has_exit { defined $_[0]->{+EXIT} } +sub has_plan { defined $_[0]->{+PLAN} } + +sub audit { + my $self = shift; + my @out = $self->_audit(@_); + + $self->update_summary() if $self->{+SUMMARY_FILE}; + + return @out; +} + +sub update_summary { + my $self = shift; + + my $done = defined($self->{+EXIT}) || defined($self->{halt}); + my $fail = $self->{+_ERRORS} || $self->{+_FAILURES} || $self->{+_SUB_FAILURES} || $self->{+EXIT} || $self->{+HALT}; + $fail ||= $done && $self->fail_error_facet_list; + + $fail = $fail ? 1 : 0; + $done = $done ? 1 : 0; + + my $new; + if ($done) { + $new = { + fail => $fail, + done => $done, + file => $self->{+FILE}, + run_id => $self->{+RUN_ID}, + job_try => $self->{+JOB_TRY}, + job_id => $self->{+JOB_ID}, + exit => $self->{+EXIT}, + halt => $self->{+HALT}, + plan => $self->{+PLAN}, + assertions => $self->{+ASSERTION_COUNT} // 0, + errors => $self->{+_ERRORS} // 0, + failures => $self->{+_FAILURES} // 0, + subtest_failures => $self->{+_SUB_FAILURES} // 0 + }; + } + else { + $new = { + file => $self->{+FILE}, + run_id => $self->{+RUN_ID}, + job_try => $self->{+JOB_TRY}, + job_id => $self->{+JOB_ID}, + fail => $fail, + done => $done, + }; + } + + my $old = $self->{+PREVIOUS_SUMMARY}; + + my $diff = $old ? keys(%$new) != keys(%$old) : 1; + if ($old && !$diff) { + for my $key (qw/fail done/) { + next if defined($old->{$key}) && $new->{$key} == $old->{$key}; + $diff++; + last; + } + } + + return if $old && !$diff; + $self->{+PREVIOUS_SUMMARY} = $new; + + if (my $file = $self->{+SUMMARY_FILE}) { + Test2::Harness::Util::File::JSON->new(name => $file)->write($new); + } + + if (my $state = $self->state) { + $state->transaction(w => sub { + my ($this, $data) = @_; + $data->{jobs}->{$self->{+RUN_ID}}->{$self->{+JOB_ID}}->{$self->{+JOB_TRY}} = $new; + }); + } +} + +sub _audit { + my $self = shift; + my ($event) = @_; + + my $f = $event->{facet_data}; + my $hf = hub_truth($f); + + my $nested = $hf->{nested} || 0; + + $self->times->process($event, $f, $self->{+ASSERTION_COUNT}) unless $nested; + + return if $hf->{buffered}; + + my $is_ours = $nested == $self->{+NESTED}; + + return unless $is_ours || $f->{from_tap}; + + # Add parent if we start a buffered subtest + if ($f->{harness} && $f->{harness}->{subtest_start}) { + my $st = $self->{+SUBTESTS}->{$nested + 1} ||= {}; + $st->{event} = $event; + $f->{harness_auditor}->{no_render} = 1; + return; + } + + my @out; + + # Not actually a subtest end, someone printed to STDOUT + if ($f->{from_tap} && $f->{harness}->{subtest_end} && !($self->{+SUBTESTS} && keys %{$self->{+SUBTESTS}})) { + # Alter $f so that this incorrect event is not sent to the renderer. + $f->{harness_auditor}->{no_render} = 1; + + # Make a new $f and $event for the rest of the processing. + $f = { + %{$f}, + harness_auditor => {added_by_auditor => 1}, + parent => undef, + trace => undef, + harness => { + %{$f->{harness} || {}}, + subtest_end => undef, + }, + info => [ + @{$f->{info} || []}, + { + details => $f->{from_tap}->{details}, + tag => $f->{from_tap}->{source} || 'STDOUT', + from_harness => 1, + } + ], + }; + + $event = Test2::Harness::Event->new(stamp => time, job_try => $self->{+JOB_TRY}, facet_data => $f); + } + + push @out => $event; + + # Close any deeper subtests + if (my $sts = $self->{+SUBTESTS}) { + my @close = sort { $b <=> $a } grep { $_ > $nested } keys %$sts; + + for my $n (@close) { + my $st = delete $sts->{$n}; + my $se = $st->{event} || $event; + + my $fd = $se->{facet_data}; + delete $fd->{harness_auditor}->{no_render}; + $fd->{parent}->{hid} ||= $n; + $fd->{parent}->{children} ||= $st->{children}; + $fd->{harness}->{closed_by} = $event; + $fd->{harness}->{closed_by_eid} = $event->{event_id}; + + my $pn = $n - 1; + + if ($st->{event}) { + if ($pn > $self->{+NESTED}) { + push @{$sts->{$pn}->{children}} => $fd; + } + elsif ($pn == $self->{+NESTED}) { + $self->subtest_process($fd, $se); + push @out => $se; + } + } + else { + push @out => $se if $self->{+NESTED} && $pn == $self->{+NESTED}; + } + } + } + + unless ($is_ours) { + my $st = $self->{+SUBTESTS}->{$nested} ||= {}; + my $fd = {%$f}; + push @{$st->{children}} => $fd; + return @out; + } + + $self->subtest_process($f, $event); + return @out; +} + +sub subtest_process { + my $self = shift; + my ($f, $event) = @_; + + my $closer = delete $f->{harness}->{closed_by}; + $event ||= Test2::Harness::Event->new(facet_data => $f, job_try => $self->{+JOB_TRY}); + + $self->{+NUMBERS}->{$f->{assert}->{number}}++ + if $f->{assert} && $f->{assert}->{number}; + + if ($f->{parent} && $f->{assert}) { + my $name = $f->{assert}->{details} // "unnamed subtest ($f->{trace}->{frame}->[1] line $f->{trace}->{frame}->[2])"; + + my $subauditor = blessed($self)->new(nested => $self->{+NESTED} + 1, file => $self->{+FILE}, job_try => $self->{+JOB_TRY}); + + my $id = 1; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness}->{job_id} ||= $f->{harness}->{job_id}; + $sf->{harness}->{run_id} ||= $f->{harness}->{run_id}; + $sf->{harness}->{event_id} ||= $sf->{about}->{uuid} ||= gen_uuid(); + $subauditor->subtest_process($sf); + } + + my @errors = $subauditor->subtest_fail_error_facet_list(); + + if ($f->{harness}->{subtest_start}) { + push @{$f->{errors}} => {tag => 'REASON', fail => 1, from_harness => 1, details => "Buffered subtest ended abruptly (missing closing brace event)"} + unless $closer && $closer->{facet_data}->{harness}->{subtest_end}; + } + + my $fail = 0; + if (@errors) { + push @{$f->{errors}} => @errors; + $fail = 1; + } + else { + $fail ||= $f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}}); + $fail ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $fail ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + } + + if ($fail) { + $self->{+_SUB_FAILURES}++; + + # Populate the tree up to this subtest + my $tree = $self->{+FAILED_SUBTEST_TREE} //= []; + push @$tree => [$name, $subauditor->{+FAILED_SUBTEST_TREE} // []]; + } + } + + $self->{+ASSERTION_COUNT}++ if $f->{assert}; + + if ($f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}})) { + $self->{+_FAILURES}++; + } + + if ($f->{control} || $f->{errors}) { + my $err ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $err ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + $self->{+_ERRORS}++ if $err; + $self->{+HALT} = $f->{control}->{details} || '1' if $f->{control} && $f->{control}->{halt} && (!$self->{+HALT} || $self->{+HALT} eq '1'); + } + + if ($f->{plan} && !$f->{plan}->{none}) { + $self->{+_PLANS}++; + $self->{+PLAN} = $f->{plan}; + } + + if ($f->{harness_job_exit}) { + $self->{+EXIT} = $f->{harness_job_exit}->{exit}; + + my $file = $self->{+FILE}; + + warn "checking if the job will retry can not be done here!"; + my $end = $f->{harness_job_end} = { + # This has to happen somewhere else. + #retry => $f->{harness_job_exit}->{retry}, + + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + fail => $self->fail(), + stamp => $f->{harness_job_exit}->{stamp}, + }; + + my $plan = $self->plan; + $end->{skip} = $plan->{details} || "No reason given" if $plan && !$plan->{count}; + + my $times = $self->times; + if ($times && $times->useful) { + $end->{times} = $times->data_dump; + push @{$f->{harness_job_fields}} => $times->job_fields; + push @{$f->{info}} => {tag => 'TIME', details => $times->summary, table => $times->table}; + } + + push @{$f->{errors}} => $self->fail_error_facet_list; + } + + return; +} + +sub subtest_fail_error_facet_list { + my $self = shift; + + my @out; + + my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; + my $count = $self->{+ASSERTION_COUNT}; + + my $numbers = $self->{+NUMBERS}; + my $max = max(keys %$numbers); + if ($max) { + for my $i (1 .. $max) { + if (!$numbers->{$i}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was never seen"}; + } + elsif ($numbers->{$i} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was seen more than once"}; + } + } + } + + if (!$self->{+_PLANS}) { + if ($count) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared"}; + } + else { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared, and no assertions were made."}; + } + } + elsif ($self->{+_PLANS} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Too many plans were declared (Count: $self->{+_PLANS})"}; + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Planned for $plan assertions, but saw $self->{+ASSERTION_COUNT}"} + if $plan && $count != $plan; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Subtest failures were encountered (Count: $self->{+_SUB_FAILURES})"} + if $self->{+_SUB_FAILURES}; + + return @out; +} + +sub fail_error_facet_list { + my $self = shift; + + my @out; + + my $incomplete_subtests = values %{$self->{+SUBTESTS}}; + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "One or more incomplete subtests (Count: $incomplete_subtests)"} + if $incomplete_subtests; + + if (my $wstat = $self->{+EXIT}) { + if ($wstat == -1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "The harness could not get the exit code! (Code: $wstat)"}; + } + else { + my $e = parse_exit($wstat); + if ($e->{err}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Err: $e->{err})"}; + } + if ($e->{sig}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $e->{sig})"}; + } + } + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Errors were encountered (Count: $self->{+_ERRORS})"} + if $self->{+_ERRORS}; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion failures were encountered (Count: $self->{+_FAILURES})"} + if $self->{+_FAILURES}; + + push @out => $self->subtest_fail_error_facet_list(); + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::Auditor - Class to monitor events for a single job +and pass judgement on the result . + +=head1 DESCRIPTION + +This module represents a per-job state tracker. This module sees every event +and manages the state produced. In the end this tracker determines if a test +job passed or failed, and why. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::Auditor; + + my $auditor = Test2::Harness::Collector::Auditor->new(); + + for my $event (@events) { + $auditor->process($event); + } + + print "Pass!" if $auditor->pass; + print "Fail!" if $auditor->fail; + +=head1 METHODS + +=over 4 + +=item $int = $auditor->assertion_count() + +Number of assertions that have been seen. + +=item $exit = $auditor->exit() + +If the job has exited this will return the exit value (integer, 0 or greater). +If the job has not exited yet (or at least if the auditor has not seen the exit +event yet) this will return undef. + +=item $bool = $auditor->fail() + +Returns true if the job has failed/is failing. + +=item @error_facets = $auditor->fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $file = $auditor->file + +If the test file is known this will return it (string). This will return undef +if the file is not yet known. + +=item $string = $auditor->halt + +If the test was halted (bail-out) this will contain the human readible reason. + +=item $bool = $auditor->has_exit + +Check if the exit value is known. + +=item $bool = $auditor->has_plan + +Check if a plan has been seen. + +=item $file = $auditor->file + +file that is running + +=item $int = $auditor->nested + +If this auditor represents a subtest this will be an integer greater than 0, +the top-level test is 0. + +=item $hash = $auditor->numbers + +This is an internal state tracking what test numbers have been seen. This is +really only applicable in tests that produced TAP. + +=item $bool = $auditor->pass + +Check if the test job is passing. + +=item $plan_facet = $auditor->plan() + +If the plan facet has been seen this will return it. + +=item $auditor->process($event); + +Modify the state based on the provided event. + +=item $auditor->subtest_fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $times = $auditor->times() + +Retuns the L<Test2::Harness::Log::TimeTracker> instance. + +=item $int = $auditor->try() + +Sometimes a job is run more than once, in those cases this will be an integer +greater than 0 representing the try. 0 is used for the first try. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Collector/IOParser.pm b/lib2.0/Test2/Harness/Collector/IOParser.pm new file mode 100644 index 000000000..3abbb3dd0 --- /dev/null +++ b/lib2.0/Test2/Harness/Collector/IOParser.pm @@ -0,0 +1,128 @@ +package Test2::Harness::Collector::IOParser; +use strict; +use warnings; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + <run_id + <job_id + <job_try + <name + <type + <tag +}; + +sub parse_io { + my $self = shift; + my ($io) = @_; + + my $stream = $io->{stream} or confess "No Stream!"; + + my $event = $self->get_event($io); + + $self->parse_process_action($io, $event) if $stream eq 'process'; + $self->parse_stream_line($io, $event) if defined $io->{line}; + + $self->normalize_event($io, $event); + + return ($event); +} + +sub normalize_event { + my $self = shift; + my ($io, $event) = @_; + + my $stamp = $event->{stamp} // $event->{facet_data}->{harness}->{stamp} // $io->{stamp} // time; + my $event_id = $event->{event_id} // $event->{facet_data}->{harness}->{event_id} // $io->{event_id} // gen_uuid(); + + my %fields = ( + stamp => $stamp, + event_id => $event_id, + run_id => $self->{+RUN_ID}, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + ); + + for my $field (keys %fields) { + if (defined $event->{$field}) { + die "'$field' mismatch, internal inconsistency." unless $event->{$field} eq $fields{$field}; + } + else { + $event->{$field} = $fields{$field}; + } + + if (defined $event->{facet_data}->{harness}->{$field}) { + die "'$field' mismatch, internal inconsistency." unless $event->{facet_data}->{harness}->{$field} eq $fields{$field}; + } + else { + $event->{facet_data}->{harness}->{$field} = $fields{$field}; + } + } +} + +sub get_event { + my $self = shift; + my ($io) = @_; + + my $event = $io->{event} // $io->{data} // { + stamp => $io->{stamp} // time, + event_id => $io->{event_id} // gen_uuid(), + facet_data => {}, + }; + + delete $io->{event}; + delete $io->{data}; + + return $event; +} + +sub parse_stream_line { + my $self = shift; + my ($io, $event) = @_; + + my $stream = $io->{stream}; + my $ucstream = uc($stream); + + my $text = delete $io->{line}; + my $tag = $self->{+TAG} // $$; + + push @{$event->{facet_data}->{info}} => { + details => $text, + tag => $tag, + debug => ($ucstream eq 'STDERR' ? 1 : 0), + }; +} + +sub parse_process_action { + my $self = shift; + my ($io, $event) = @_; + + my $action = $io->{action} or return; + my $data = $io->{$action}; + my $name = $self->{+NAME}; + my $type = $self->{+TYPE}; + + if ($action eq 'launch') { + $event->{facet_data}->{launch} = $data; + push @{$event->{facet_data}->{info}} => { + tag => 'PROCESS', + details => "Launched '$type' process `$name`", + }; + } + + if ($action eq 'exit') { + $event->{facet_data}->{exit} = $data; + push @{$event->{facet_data}->{info}} => { + tag => 'PROCESS', + details => "'$type' process `$name` exited with status $data->{exit}->{all}", + debug => $data->{exit}->{all} ? 1 : 0, + }; + } +} + +1; diff --git a/lib2.0/Test2/Harness/Collector/IOParser/Stream.pm b/lib2.0/Test2/Harness/Collector/IOParser/Stream.pm new file mode 100644 index 000000000..4220e79c8 --- /dev/null +++ b/lib2.0/Test2/Harness/Collector/IOParser/Stream.pm @@ -0,0 +1,47 @@ +package Test2::Harness::Collector::IOParser::Stream; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Collector::TapParser qw/parse_stdout_tap parse_stderr_tap/; + +use parent 'Test2::Harness::Collector::IOParser'; +use Test2::Harness::Util::HashBase qw{}; + +sub parse_stream_line { + my $self = shift; + my ($io, $event) = @_; + + my $stream = $io->{stream}; + my $text = $io->{line}; + + my $facets = $stream eq 'stdout' ? parse_stdout_tap($text) : parse_stderr_tap($text); + + if ($facets) { + $event->{facet_data} = $facets; + return; + } + + return $self->SUPER::parse_stream_line(@_); +} + +sub parse_process_action { + my $self = shift; + my ($io, $event) = @_; + + $self->SUPER::parse_process_action(@_); + + my $action = $io->{action} or return; + my $data = $io->{$action}; + + if ($action eq 'exit') { + $event->{facet_data}->{harness_job_exit} = { + exit => $data->{exit}->{all}, + stamp => $data->{stamp}, + }; + } +} + + +1; diff --git a/lib2.0/Test2/Harness/Collector/TapParser.pm b/lib2.0/Test2/Harness/Collector/TapParser.pm new file mode 100644 index 000000000..39520ef97 --- /dev/null +++ b/lib2.0/Test2/Harness/Collector/TapParser.pm @@ -0,0 +1,383 @@ +package Test2::Harness::Collector::TapParser; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer 'Importer' => 'import'; + +our @EXPORT_OK = qw{ + parse_stdout_tap + parse_stderr_tap + parse_tap_line +}; + +sub parse_stdout_tap { + my ($line) = @_; + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{from_tap} = { source => 'STDOUT', details => $line }; + return $facet_data; +} + + +sub parse_stderr_tap { + my ($line) = @_; + + # STDERR only has comments + return unless $line =~ m/^\s*#/; + + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{info}->[-1]->{tag} = 'DIAG'; + $facet_data->{info}->[-1]->{debug} = 1; + $facet_data->{from_tap} = { source => 'STDERR', details => $line }; + + return $facet_data; +} + +sub parse_tap_line { + my ($line) = @_; + return __PACKAGE__->_parse_tap_line($line); +} + +sub _parse_tap_line { + my $class = shift; + my ($line) = @_; + chomp($line); + + my ($lead, $lead_len, $nest, $str) = ('', 0, 0, $line); + if ($line =~ m/^(\s+)\S/) { + $lead = $1; + $str =~ s/^\Q$lead\E//mg; + + $lead =~ s/\t/ /g; + $lead_len = length($lead); + + # indentation other than 0 or a multiple of 4 spaces... not an event + return undef if $lead_len % 4; + + $nest = $lead_len / 4; + } + + my @types = qw/buffered_subtest comment plan bail version/; + for my $type (@types) { + my $sub = "parse_tap_$type"; + my $facet_data = $class->$sub($str) or next; + $facet_data->{trace}->{nested} = $nest; + $facet_data->{hubs}->[0]->{nested} = $nest; + return $facet_data; + } + + return undef; +} + +sub parse_tap_buffered_subtest { + my $class = shift; + my ($line) = @_; + + # End of a buffered subtest. + return {parent => {}, harness => {subtest_end => 1}} if $line =~ m/^\}\s*$/; + + my $facet_data = $class->parse_tap_ok($line) or return undef; + return $facet_data unless $facet_data->{assert}->{details} =~ s/\s*\{\s*$//g; + + $facet_data->{parent} = { + details => $facet_data->{assert}->{details}, + }; + $facet_data->{harness}->{subtest_start} = 1; + + return $facet_data; +} + +sub parse_tap_ok { + my $class = shift; + my ($line) = @_; + + my ($pass, $todo, $skip, $num, @errors); + + return undef unless $line =~ s/^(not )?ok\b//; + $pass = !$1; + + push @errors => "'ok' is not immediately followed by a space." + if $line && !($line =~ m/^ /); + + if ($line =~ s/^(\s*)(\d+)\b//) { + my $space = $1; + $num = $2; + + push @errors => "Extra space after 'ok'" + if length($space) > 1; + } + + # Not strictly compliant, but compliant with what Test-Simple does... + # Standard does not have a todo & skip. + if ($line =~ s/#\s*(todo & skip|todo|skip)(.*)$//i) { + my ($directive, $reason) = ($1, $2); + + push @errors => "No space before the '#' for the '$directive' directive." + unless $line =~ s/\s+$//; + + push @errors => "No space between '$directive' directive and reason." + if $reason && !($reason =~ s/^\s+//); + + $skip = $reason if $directive =~ m/skip/i; + $todo = $reason if $directive =~ m/todo/i; + } + + # Standard says that everything after the ok (except the number) is part of + # the name. Most things add a dash between them, and I am deviating from + # standards by stripping it and surrounding whitespace. + $line =~ s/\s*-\s*//; + + $line =~ s/^\s+//; + $line =~ s/\s+$//; + + my $is_subtest = ($line =~ m/^Subtest:\s*(.*)$/) ? ($1 or 1) : undef; + + my $facet_data = { + assert => { + pass => $pass, + no_debug => 1, + details => $line, + defined $num ? (number => $num) : (), + }, + }; + + $facet_data->{parent} = { + details => $is_subtest, + } if defined $is_subtest; + + push @{$facet_data->{amnesty}} => { + tag => 'SKIP', + details => $skip, + } if defined $skip; + + push @{$facet_data->{amnesty}} => { + tag => 'TODO', + details => $todo, + } if defined $todo; + + push @{$facet_data->{info}} => { + details => $_, + debug => 1, + tag => 'PARSER', + } for @errors; + + return $facet_data; +} + +sub parse_tap_version { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^TAP version\s/; + + return { + about => { + details => $line, + }, + info => [ + { + tag => 'INFO', + debug => 0, + details => $line, + } + ], + }; +} + +sub parse_tap_plan { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ s/^1\.\.(\d+)//; + my $max = $1; + + my ($directive, $reason) = ("", ""); + + if ($max == 0) { + if ($line =~ s/^\s*#\s*//) { + if ($line =~ s/^(skip)\S*\s*//i) { + $directive = uc($1); + $reason = $line; + $line = ""; + } + } + + $directive ||= "SKIP"; + $reason ||= "no reason given"; + } + + my $facet_data = { + plan => { + count => $max, + skip => ($directive eq 'SKIP') ? 1 : 0, + details => $reason, + } + }; + + push @{$facet_data->{info}} => { + details => 'Extra characters after plan.', + debug => 1, + tag => 'PARSER', + } if $line =~ m/\S/; + + return $facet_data; +} + +sub parse_tap_bail { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^Bail out!\s*(.*)$/; + + return { + control => { + halt => 1, + details => $1, + } + }; +} + +sub parse_tap_comment { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^\s*#/; + + $line =~ s/^\s*# ?//msg; + + return { + info => [ + { + details => $line, + tag => 'NOTE', + debug => 0, + } + ] + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::TapParser - Produce EventFacets from a line of TAP. + +=head1 DESCRIPTION + +This module is responsible for reading and processing any TAP output from +tests. Lines of TAP output are processed into L<Test2::Event> facet data. Note +that C<< Test2 -> TAP -> Test2 >> is lossy at the C<< Test2 -> TAP >> step. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::TapParser qw/parse_tap_line/; + + my $facet_data = parse_tap_line("1..1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + plan => { + details => '', + count => 1, + skip => 0, + }, + }, + "Parsed the plan" + ); + + $facet_data = parse_tap_line("# foo"); + is( + $facet_data, + { + trace => { nested => 0 }, + hubs => [ { nested => 0 } ], + info => [ + { + tag => 'NOTE', + details => 'foo', + debug => 0, + }, + ], + }, + + "Parsed the note" + ); + + $facet_data = parse_tap_line("ok 1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + assert => { + no_debug => 1, + pass => 1, + number => '1', + details => '', + }, + }, + "Parsed the assertion" + ); + +=head1 EXPORTS + +=over 4 + +=item $facet_data = parse_tap_line($line) + +Parse a line of TAP. It is assumed to be STDOUT thus all comments are turned +into notes. Using this export will B<NOT> add the usual C<from_tap> facet. It +is better to use one of the other 2 exports. + +=item $facet_data = parse_stdout_tap($line) + +Parse a line of TAP from stdout. + +=item $facet_data = parse_stderr_tap($line) + +Parse a line of TAP from stderr. This will B<ONLY> parse comment lines (ones +that start with a C<#>, which may be indented). All comments will be treated as +diag's, all other lines will be ignored. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Event.pm b/lib2.0/Test2/Harness/Event.pm new file mode 100644 index 000000000..5f207ce2d --- /dev/null +++ b/lib2.0/Test2/Harness/Event.pm @@ -0,0 +1,216 @@ +package Test2::Harness::Event; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::JSON qw/encode_json/; + +use Importer 'Test2::Util::Facets2Legacy' => ':ALL'; + +BEGIN { + require Test2::Event; + our @ISA = ('Test2::Event'); + + # Currently the base class for events does not have init(), that may change + if (Test2::Event->can('init')) { + *INIT_EVENT = sub() { 1 } + } + else { + *INIT_EVENT = sub() { 0 } + } +} + +use Test2::Harness::Util::HashBase qw{ + <facet_data + <stream_id + <event_id + <run_id + <job_id + <job_try + <stamp + +json + processed +}; + +sub trace { $_[0]->{+FACET_DATA}->{trace} } +sub set_trace { confess "'trace' is a read only attribute" } + +sub init { + my $self = shift; + + $self->Test2::Event::init() if INIT_EVENT; + + my $data = $self->{+FACET_DATA} || confess "'facet_data' is a required attribute"; + + for my $field (RUN_ID(), JOB_ID(), JOB_TRY(), EVENT_ID()) { + my $v1 = $self->{$field}; + my $v2 = $data->{harness}->{$field}; + + my $d1 = defined($v1); + my $d2 = defined($v2); + + confess "'$field' is a required attribute" + unless $d1 || $d2 || ($field eq +JOB_TRY && !$self->{+JOB_ID}); + + confess "'$field' has different values between attribute and facet data" + if $d1 && $d2 && $v1 ne $v2; + + $self->{$field} = $data->{harness}->{$field} = $v1 // $v2; + } + + delete $data->{facet_data}; + + # Original trace wins. + if (my $trace = delete $self->{+TRACE}) { + $self->{+FACET_DATA}->{trace} //= $trace; + } +} + +sub as_json { $_[0]->{+JSON} //= encode_json($_[0]) } + +sub TO_JSON { + my $out = {%{$_[0]}}; + + $out->{+FACET_DATA} = { %{$out->{+FACET_DATA}} }; + delete $out->{+FACET_DATA}->{harness_job_watcher}; + delete $out->{+FACET_DATA}->{harness}->{closed_by}; + delete $out->{+JSON}; + delete $out->{+PROCESSED}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Event - Subclass of Test2::Event used by Test2::Harness under +the hood. + +=head1 DESCRIPTION + +Test2 tests produce a sequence of events objects L<Test2::Event>. This is a +subclass of those events for use in L<Test2::Harness>. Event non-test tests +which produce TAP output will have the output parsed into these types of +events. + +=head1 SYNOPSIS + +In normal usage ou will never need to create one fo these events yourself. This +documentation assumes you are operating on an existing event C<$event> that the +harness exposed to you via a plugin or similar. + + my $facet_data = $event->facet_data; + my $run_id = $event->run_id; + my $job_id = $event->job_id; + my $job_try = $event->job_try; + my $event_id = $event->event_id; + +=head1 METHODS + +See L<Test2::Event> for methods provided by the base class. + +=over 4 + +=item $hashref = $event->TO_JSON + +Used for json serialization. + +=item $json_string = $event->as_json + +This will return a json representation of the event. Note that this is a lossy +conversion with some harness specific state removed by design. This may even be +a cached copy of the json string that was decoded to produce the original +object. If the string was not cached before it will be cached for all future +calls ignoring any state change to the event. + +The lossy/cached conversion is intended so that events get passed through the +harness pipeline without modifications from one step translating to another. If +you need something extra to go through you need to either replace the event or +create an additional one. + +=item $string = $event->event_id + +Usually a UUID, but not always! + +=item i$hashref = $event->facet_data + +Get the event facet data, this is the meat of the event that hold all the +state. + +=item $string = $event->job_id + +Usually a UUID, but not always! + +=item $int = $event->job_try + +Integer, 0 or greater. Some jobs are run additional times if they fail, this +says which attempt the event is for. The counter starts at 0. + +=item $bool = $event->processed + +This will be true if the event has been process by the harness. Note that this +attibute is not serialized by C<TO_JSON> or C<as_json>. + +=item $string = $event->run_id + +The run id. This is usually a UUID, but not always! + +=item $ts = $event->stamp + +A unix timestamp for when the event was created. + +=item $id = $event->stream_id + +This is an implementation detail of L<Test2::Formatter::Stream>, do not rely on +it. This is used to prevent parsing errors when stream output is nested in +other stream output, which can happen if you are writing tests for the stream +formatter itself. + +=item $trace = $event->trace + +This si a shortcut for C<< $event->facet_data->{trace} >>. The trace data is +essential and used everywhere. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Plugin.pm b/lib2.0/Test2/Harness/Plugin.pm new file mode 100644 index 000000000..6dc61b0a0 --- /dev/null +++ b/lib2.0/Test2/Harness/Plugin.pm @@ -0,0 +1,349 @@ +package Test2::Harness::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +# Document, but do not implement +#sub changed_files {} +#sub changed_diff {} + +sub munge_search {} + +sub claim_file {} + +sub munge_files {} + +sub inject_run_data {} + +sub setup {} + +sub teardown {} + +sub TO_JSON { ref($_[0]) || "$_[0]" } + +sub redirect_io { + my $this = shift; + my ($settings, $name) = @_; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "This cannot be used without a workspace $at" unless $settings->check_prefix('workspace'); + + require File::Spec; + require Test2::Harness::Util::IPC; + + my $dir = $settings->workspace->workdir; + my $aux = File::Spec->catdir($dir, 'aux_logs'); + mkdir($aux) unless -d $aux; + + Test2::Harness::Util::IPC::swap_io(\*STDOUT, File::Spec->catfile($aux, "${name}-STDOUT.log")); + Test2::Harness::Util::IPC::swap_io(\*STDERR, File::Spec->catfile($aux, "${name}-STDERR.log")); + + return; +} + +sub shellcall { + my $this = shift; + my ($settings, $name, @cmd) = @_; + + require POSIX; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "No command provided $at" unless @cmd && length($cmd[0]); + + my $pid = fork // die "Could not fork: $!"; + if ($pid) { + waitpid($pid, 0); + return $?; + } + else { + local $@; + + eval { + if ($settings->check_prefix('workspace')) { + $this->redirect_io($settings, $name); + } + exec(@cmd) if @cmd > 1; + exec($cmd[0]); + }; + + chomp(my $err = $@ // "unknown error"); + + warn "Could not run command ($@) $at"; + POSIX::_exit(1); + } +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Plugin - Base class for Test2::Harness plugins. + +=head1 DESCRIPTION + +This class holds the methods specific to L<Test2::Harness> which +is the backend. Most of the time you actually want to subclass +L<App::Yath::Plugin> which subclasses this class, and holds additional methods +that apply to yath (the UI layer). + +=head1 SYNOPSIS + +You probably want to subclass L<App::Yath::Plugin> instead. This class here +mainly exists to separate concerns, but is not something you should use +directly. + + package Test2::Harness::Plugin::MyPlugin; + + use parent 'Test2::Harness::Plugin'; + + # ... Define methods + + 1; + +=head1 METHODS + +=over 4 + +=item $plugin->munge_search($input, $default_search, $settings) + +C<$input> is an arrayref of files and/or directories provided at the command +line. + +C<$default_search> is an arrayref with the default files/directories pulled in +when nothing is specified at the command ine. + +C<$settings> is an instance of L<Test2::Harness::Settings> + +=item $undef_or_inst = $plugin->claim_file($path, $settings) + +This is a chance for a plugin to claim a test file early, before Test2::Harness +takes care of it. If your plugin does not want to claim the file just return +undef. To claim the file return an instance of L<Test2::Harness::Task::TestFile> +created with C<$path>. + +=item $plugin->munge_files(\@tests, $settings) + +This is an opportunity for your plugin to modify the data for any test file +that will be run. The first argument is an arrayref of +L<Test2::Harness::Task::TestFile> objects. + +=item $hashref = $plugin->duration_data($settings, $test_names) + +If defined, this can return a hashref of duration data. This should return +undef if no duration data is provided. The first plugin listed that provides +duration data wins, no other plugins will be checked once duration data is +obtained. + +Example duration data: + + { + 't/foo.t' => 'medium', + 't/bar.t' => 'short', + 't/baz.t' => 'long', + } + +=item $hashref_or_arrayref = $plugin->coverage_data(\@changed) + +=item $hashref_or_arrayref = $plugin->coverage_data() + +If defined, this can return a hashref of all coverage data, or an arrayref of +tests that cover the tests listed in @changed. This should return undef if no +coverage data is available. The first plugin to provide coverage data wins, no +other plugins will be checked once coverage data has been obtained. + +Examples: + + [ + 'foo.t', + 'bar.t', + 'baz.t', + ] + + { + 'lib/Foo.pm' => [ + 't/foo.t', + 't/integration.t', + ], + 'lib/Bar.pm' => [ + 't/bar.t', + 't/integration.t', + ], + } + +=item $plugin->post_process_coverage_tests($settings, \@tests) + +This is an opportunity for a plugin to do post-processing on the list of +coverage tests to run. This is mainly useful to remove duplicates if multiple +plugins add coverage data, or merging entries where applicable. This will be +called after all plugins have generated their coverage test list. + +Plugins may implement this without implementing coverage_data(), making this +useful if you want to use a pre-existing coverage module and want to do +post-processing on what it provides. + +=item $plugin->inject_run_data(meta => $meta, fields => $fields, run => $run) + +This is a callback that lets your plugin add meta-data or custom fields to the +run event. The meta-data and fields are available in the event log, and are +particularily useful to L<App::Yath::UI>. + + sub inject_run_data { + my $class = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + # Meta-data is a hash, each plugin should define its own key, and put + # data under that key + $meta->{MyPlugin}->{stuff} = "Stuff!"; + + # Fields is an array of fields that a UI might want to display when showing the run. + push @$fields => {name => 'MyPlugin', details => "Human Friendly Stuff", raw => "Less human friendly stuff", data => $all_the_stuff}; + + return; + } + +=item $plugin->setup($settings) + +This is a callback that lets you run setup logic when the runner starts. Note +that in a persistent runner this is run once on startup, it is not run for each +C<run> command against the persistent runner. + +=item $plugin->teardown($settings) + +This is a callback that lets you run teardown logic when the runner stops. Note +that in a persistent runner this is run once on termination, it is not run for +each C<run> command against the persistent runner. + +=item @files = $plugin->changed_files($settings) + +Get a list of files that have changed. Plugins are free to define what +"changed" means. This may be used by the finder to determine what tests to run +based on coverage data collected in previous runs. + +Note that data from all changed_files() calls from all plugins will be merged. + +=item ($type, $value) = $plugin->changed_diff($settings) + +Generate a diff that can be used to calculate changed files/subs for which to +run tests. Unlike changed_files(), only 1 diff will be used, first plugin +listed that returns one wins. This is not run at all if a diff is provided via +--changed-diff. + +Diffs must be in the same format as this git command: + + git diff -U1000000 -W --minimal BASE_BRANCH_OR_COMMIT + +Some other diff formats may work by chance, but they are not dirfectly +supported. In the future other diff formats may be directly supported, but not +yet. + +The following return sets are allowed: + +=over 4 + +=item file => string + +Path to a diff file + +=item diff => string + +In memory diff as a single string + +=item lines => \@lines + +Diff where each line is a seperate string in an arrayref. + +=item line_sub => sub { ... } + +Sub that returns one line per call and undef when there are no more lines + +=item handle => $FH + +A filehandle to the diff + +=back + +=item $exit = $plugin->shellcall($settings, $name, $cmd) + +=item $exit = $plugin->shellcall($settings, $name, @cmd) + +This is essentially the same as C<system()> except that STDERR and STDOUT are +redirected to files that the yath collector will pick up so that any output +from the command will be seen as events and will be part of the yath log. If no +workspace is available this will not redirect IO and it will be identical to +calling C<system()>. + +This is particularily useful in C<setup()> and C<teardown()> when running +external commands, specially any that daemonize and continue to produce output +after the setup/teardown method has completed. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->redirect_io($settings, $name) + +B<WARNING:> This must NEVER be called in a primary yath process. Only use this +in forked processes that you control. If this is used in a main process it +could hide ALL output. + +This will redirect STDERR and STDOUT to files that will be picked up by the +yath collector so that any output appears as proper yath events and will be +included in the yath log. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->TO_JSON + +This is here as a bare minimum serialization method. It returns the plugin +class name. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Resource.pm b/lib2.0/Test2/Harness/Resource.pm new file mode 100644 index 000000000..c487e8a42 --- /dev/null +++ b/lib2.0/Test2/Harness/Resource.pm @@ -0,0 +1,19 @@ +package Test2::Harness::Resource; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{}; + +sub applies_to_all_tests { 0 } +sub applies_to_test { 0 } +sub available { 0 } +sub available_for_test { 0 } +sub allocate_for_test { croak "Not Implemented" } +sub release_for_test { croak "Not Implemented" } + +1; diff --git a/lib2.0/Test2/Harness/Run.pm b/lib2.0/Test2/Harness/Run.pm new file mode 100644 index 000000000..4b731bc0a --- /dev/null +++ b/lib2.0/Test2/Harness/Run.pm @@ -0,0 +1,200 @@ +package Test2::Harness::Run; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use File::Spec; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + <author_testing + <dbi_profiling + +env_vars + <event_uuids + <fields + <input + <input_file + <links + <load + +load_import + <mem_usage + <meta + <retry + <retry_isolated + <run_id + <stream + <test_args +}; + +sub init { + my $self = shift; + + croak "run_id is required" + unless $self->{+RUN_ID}; +} + +warn "FIXME"; +#sub run_dir { +# my $self = shift; +# my ($workdir) = @_; +# return File::Spec->catfile($workdir, $self->{+RUN_ID}); +#} + +sub env_vars { + my $self = shift; + + my %env = %{$self->{+ENV_VARS} //= {}}; + + $env{AUTHOR_TESTING} = 1 if $self->author_testing; + + return \%env; +} + +sub load_import { + my $self = shift; + + my %load_import = %{$self->{+LOAD_IMPORT} //= {}}; + + if ($self->dbi_profiling) { + push @{$load_import{'@'}} => 'Test2::Plugin::DBIProfile' unless $load_import{'Test2::Plugin::DBIProfile'}; + $load_import{'Test2::Plugin::DBIProfile'} //= []; + } + + return \%load_import; +} + +warn "FIXME"; +#sub queue_item { +# my $self = shift; +# my ($plugins) = @_; +# +# croak "a plugins arrayref is required" unless $plugins; +# +# my $out = {%$self}; +# +# my $meta = $out->{+META} //= {}; +# my $fields = $out->{+FIELDS} //= []; +# for my $p (@$plugins) { +# $p->inject_run_data(meta => $meta, fields => $fields, run => $self); +# } +# +# return $out; +#} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Run - Representation of a set of tests to run, and their +options. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be modified. + +See L<App::Yath::Options::Run> for more documentation on these. + +=head2 FROM OPTIONS + +=over 4 + +=item $bool = $run->author_testing + +=item $hashref = $run->env_vars + +=item $bool = $run->event_uuids + +=item $arrayref = $run->fields + +=item $string = $run->input + +=item $path = $run->input_file + +=item $bool = $run->io_events + +=item $arrayref = $run->links + +=item $arrayref = $run->load + +=item $hashref = $run->load_import + +=item $bool = $run->mem_usage + +=item $int = $run->retry + +=item $bool = $run->retry_isolated + +=item $string = $run->run_id + +=item $arrayref = $run->test_args + +=item $bool = $run->use_stream + +=back + +=head2 OTHER + +=over 4 + +=item $hashref = $run->meta + +meta-data plugins may have attached. + +=back + +=head1 METHODS + +=over 4 + +=item $path = $run->run_dir($workdir) + +Returns the path C<"$workdir/$run_id">. + +=item $hashref = $run->queue_item(\@PLUGINS) + +Gets the queue item that represents this object. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Runner.pm b/lib2.0/Test2/Harness/Runner.pm new file mode 100644 index 000000000..e91287380 --- /dev/null +++ b/lib2.0/Test2/Harness/Runner.pm @@ -0,0 +1,441 @@ +package Test2::Harness::Runner; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Linux::Inotify2; +use Long::Jump qw/longjump/; +use Test2::Harness::Util qw/parse_exit mod2file/; +use POSIX ":sys_wait_h"; +use Time::HiRes qw/time/; + +use Carp qw/confess croak/; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + dump_depmap + preloads + runner_id + test_params + <stage <stage_name + <queue + <eager + + tasks_todo + + <ready <status <error <children +}; + +sub init { + my $self = shift; + + $self->{+QUEUE} //= {}; + + $self->SUPER::init(); + + confess "'runner_id' is a required attribute" unless $self->{+RUNNER_ID}; + + $self->{+CHILDREN} //= []; + $self->{+TASKS_TODO} //= []; +} + +sub start { + my $self = shift; + + require Test2::API; + Test2::API::test2_start_preload(); + + $self->start_stage(stage => 'base'); + + return 0; +} + +sub load_stage { + my $self = shift; + + my $stage = $self->stage; + + my $ok = eval { $stage->load(); 1 }; + my $err = $@; + + if ($ok) { + $self->state->{error} = undef; + $self->state->{status} = "Spawning"; + + $self->transaction( + w => sub { + $self->{+READY} = 0; + $self->{+ERROR} = undef; + $self->{+STATUS} = 'Spawning'; + } + ); + + return; + } + + $self->transaction( + w => sub { + $self->{+READY} = 0; + $self->{+ERROR} = $err; + $self->{+STATUS} = 'Failed, will retry'; + } + ); + + warn "\n=== Preload stage '$self->{+STAGE_NAME}' failed (Will try again in 5 seconds) ===\n$err\n======\n\n"; + sleep 5; + exit(255); +} + +sub start_stage { + my $self = shift; + my %params = @_; + + my $stage = delete $params{stage}; + my $children = delete $params{children} // []; + + $self->transaction( + w => sub { + if (ref($stage)) { + $self->{+STAGE} = $stage; + $self->{+STAGE_NAME} = $stage->name; + $self->{+EAGER} = $stage->eager; + } + else { + $self->{+STAGE} = undef; + $self->{+STAGE_NAME} = $stage; + } + + $self->{+PID} = $$; + $self->{+READY} = 0; + $self->{+ERROR} = undef; + $self->{+STATUS} = 'Initializing'; + + $self->{+CHILDREN} = $children; + } + ); + + warn "FIXME!"; + $SIG{TERM} = sub { print "Stage '$self->{+STAGE_NAME}' Got SIGTERM...\n"; $self->restart }; + $SIG{CHLD} = sub { 1 }; # Required to break inotify poll + + my $inotify = Linux::Inotify2->new or $self->state->abort("Could not initialize Linux::Inotify2: $!"); + $inotify->watch($self->state->state_file, IN_MODIFY, sub { $self->iterate_tasks }) or $self->state->abort("Could not watch state file: $!"); + + my $reloader; warn "FIXME: Init reloader"; + + my %seen = map {($_ => 1)} keys %INC; + + my $preloads = $self->preloads; + if ($preloads && @$preloads) { + require Test2::Harness::Runner::Preload; + my $preload = Test2::Harness::Runner::Preload->new(); + + for my $mod (@{$self->preloads // []}) { + eval { require(mod2file($mod)); 1 } or $self->state->abort("Could not preload '$mod': $@"); + next unless $mod->can('TEST2_HARNESS_PRELOAD'); + $preload->merge($mod->TEST2_HARNESS_PRELOAD); + } + + push @{$self->{+CHILDREN}} => @{$preload->stage_list}; + } + + $self->load_stage() if ref($stage); + + for my $short (keys %INC) { + next if $seen{$short}++; + my $file = $INC{$short} or next; + $inotify->watch($file, IN_MODIFY | IN_ATTRIB, sub { $self->handle_code_change($reloader, $inotify, @_) }) or $self->state->abort("Could not watch '$file': $!"); + } + + $self->transaction(w => sub { $self->{+READY} = 1; $self->{+ERROR} = undef; $self->{+STATUS} = 'Ready' }); + + $SIG{CHLD} = sub { 1 }; # Required to break inotify poll + while (1) { + exit(0) if $self->state->shared_get('scheduler')->done; + $self->iterate_children(); + $self->iterate_tasks(); + $inotify->poll; + } +}; + +sub handle_code_change { + my $self = shift; + my ($reloader, $inotify, $e) = @_; + + my $watch = $e->w; + my $file = $watch->name; + $watch->cancel; + + warn "Inotify overflow detected. Some files may have changed without triggering a reload" + if $e->IN_Q_OVERFLOW; + + unless (eval { $self->_handle_code_change($reloader, $inotify, $e, $file); 1 }) { + my $err = $@; + warn "\nError processing reload of file '$file'. Restarting stage '$self->{+STAGE_NAME}' and child stages...\n====\n$err\n====\n\n"; + $self->restart(); + } + + # Put watch back in place. + $inotify->watch($file, IN_MODIFY | IN_ATTRIB, sub { $self->handle_code_change($reloader, $inotify, @_) }) or $self->state->abort("Could not watch '$file': $!"); + + return; +} + +sub _handle_code_change { + my $self = shift; + my ($reloader, $inotify, $e, $file) = @_; + + if (my $stage = $self->stage) { + if (my $cb = $stage->watches->{$file}) { + print "Detected change in file '$file', passing to custom handler...\n"; + return $cb->($file); + } + } + + if ($reloader && $reloader->can_reload($file)) { + print "Detected change in file '$file', attempting to reload in place...\n"; + return $reloader->reload($file); + } + + print "Detected change in file '$file', terminating stage '$self->{+STAGE_NAME}' for reload...\n"; + $self->restart(); +} + +sub restart { + my $self = shift; + + print "Stage '$self->{+STAGE_NAME}' is restarting...\n"; + + $self->transaction(w => sub { $self->{+READY} = 0; $self->{+ERROR} = undef; $self->{+STATUS} = 'Restarting' }); + $self->kill_children('TERM'); + + exit 0 if $self->{+STAGE}; + longjump "Test-Runner" => 'respawn'; + die "long jump failed"; +} + +sub kill_children { + my $self = shift; + my ($sig) = @_; + + $sig //= 'TERM'; + + my $children = $self->{+CHILDREN} or return; + return unless @$children; + + my $stages = $self->fetch_stages; + + for my $child (@$children) { + my $child_name = $child->name; + my $inst = $stages->{$child_name} or next; + + next if defined $inst->exit_code; + $inst->kill($sig); + } +} + +sub fetch_stages { + my $self = shift; + + my %stages; + $self->transaction(r => sub { + %stages = map {($_->stage_name, $_)} $self->harness->shared_all('runner'); + }); + + return \%stages; +} + +sub iterate_children { + my $self = shift; + + my $children = $self->{+CHILDREN} or return; + return unless @$children; + + my $harness = $self->state; + my $exits = $harness->wait_ready(); + + for my $proc (values %$exits) { + next unless blessed($proc) && $proc->isa(__PACKAGE__); + my $exit = $proc->exit_code; + my $vals = parse_exit($exit); + + warn "Stage: '$proc->{+STAGE_NAME}' exited with status $exit (err: $vals->{err}, sig: $vals->{sig})\n"; + $proc->transaction( + w => sub { + $proc->{+READY} = 0; + $proc->{+ERROR} = $exit ? "exited with status $exit (err: $vals->{err}, sig: $vals->{sig})" : undef; + $proc->{+STATUS} = 'Down'; + } + ); + } + + my $stages = $self->fetch_stages; + + for my $child (@$children) { + my $child_name = $child->name; + my $inst = $stages->{$child_name}; + + next if $inst && $inst->pid && !defined($inst->exit_code); + + my $old = $harness->shared_delete($child_name) // {}; + + my %params = (%$self, %{$inst// {}}, %$old); + delete $params{$_} for PID(), EXIT_CODE(), READY(), ERROR(), STAGE_NAME(), STAGE(), PRELOADS(); + + $inst = $harness->shared_init(runner => $child_name, %params); + $inst->spawn(run_method => 'start_stage', stage => $child, children => $child->children // []); + } +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + + $self->transaction(w => sub { push @{$self->{+TASKS_TODO}} => $task }); +} + +sub iterate_tasks { + my $self = shift; + + $self->transaction(w +} + + +1; + +__END__ + + my $change_handler = sub { + my ($e) = @_; + my $file = $e->{w}{name}; + + warn "Inotify overflow detected. Some files may have changed without triggering a reload" + if $e->IN_Q_OVERFLOW; + + if (ref($stage) && $stage->watches->{$file}) { + print "Detected change in file '$file', passing to custom handler...\n"; + return $stage->watches->{$file}->($file); + } + + if (my $reloader = $self->reloader) { + if ($reloader->can_reload($file)) { + print "Detected change in file '$file', attempting to reload in place...\n"; + return if eval { $reloader->reload($file); 1 }; + + warn "\nReload in-place of '$file' failed, terminating stage (and child stages) for full reload.\n====\n$@\n====\n\n"; + $terminate->(); + }; + } + + print "Detected change in file '$file', terminating stage (and child stages) for reload...\n"; + $terminate->(); + }; + + my $task_handler = sub { + my ($e) = @_; + + warn "Inotify overflow detected. Some files may have changed without triggering a reload" + if $e && $e->IN_Q_OVERFLOW; + + while (my $task = $self->next_task_for_stage($name)) { + warn "fixme $task"; + #$self->state->spawn_task( + # task => $task, + # stage => $stage, + # preload_launch => ["Test-Runner", 'run_test', $task, $stage], + #); + } + }; + + my $inotify = Linux::Inotify2->new or $self->state->abort("Could not initialize Linux::Inotify2: $!"); + $inotify->watch($self->state->state_file, IN_MODIFY, $task_handler) or $self->state->abort("Could not watch state file: $!"); + + my %seen = map {($_ => 1)} keys %{$params{loaded} // {}}; + for my $file (values %INC) { + next if $seen{$file}++; + my $fname = $file; + $inotify->watch($file, IN_MODIFY | IN_ATTRIB, $change_handler) or $self->state->abort("Could not watch '$file': $!"); + } + + $self->update_stage($name, pid => $$, ready => 1, state => "Ready", error => undef); + + $SIG{CHLD} = sub { 1 }; # Required to break inotify poll + while (1) { + exit(0) if $self->state->shared_get('scheduler')->done; + $child_upkeep->(); + $task_handler->(); + $inotify->poll; + } +} + + +__END__ +sub update_stage { + my $self = shift; + my ($name, %params) = @_; + + $params{stamp} = time; + $params{name} = $name; + + $self->transaction(w => sub { $self->{+STAGES}->{$name} = \%params }); +} + +sub skip_task { die "FIXME" } + +sub queue_task_for_stage { + my $self = shift; + my ($stage, $task) = @_; + + $self->transaction(w => sub { + confess "Invalid stage '$stage'" unless $self->{+STAGES}->{$stage}; + push @{$self->{+QUEUE}->{$stage} //= []} => $task; + }); +} + +sub next_task_for_stage { + my $self = shift; + my ($stage) = @_; + + my $have_task = 0; + $self->transaction(r => sub { + confess "Invalid stage '$stage'" unless $self->{+STAGES}->{$stage}; + my $queue = $self->{+QUEUE}->{$stage} or return; + return unless @$queue; + $have_task = 1; + }); + + return unless $have_task; + + my $task; + $self->transaction(w => sub { $task = shift @{$self->{+QUEUE}->{$stage}} }); + return $task; +} + + + +1; + +__END__ + + my @stages = $stages ? $stages->stage_list : (); + for my $stage (@stages) { + next if $stage eq 'base'; + $self->start_stage($base); + die "Returned from stage, that should not happen.\n"; + } + + + $self->watch(\%already_loaded) if $self->reload; + + return unless $mod->can('TEST2_HARNESS_PRELOAD'); + + die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; + + $self->{+STAGED} //= do { + require Test2::Harness::Runner::Preload; + Test2::Harness::Runner::Preload->new(); + }; + + $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); + diff --git a/lib2.0/Test2/Harness/Runner/Preload.pm b/lib2.0/Test2/Harness/Runner/Preload.pm new file mode 100644 index 000000000..331b6b7fd --- /dev/null +++ b/lib2.0/Test2/Harness/Runner/Preload.pm @@ -0,0 +1,569 @@ +package Test2::Harness::Runner::Preload; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use Test2::Harness::Runner::Preload::Stage(); + +sub import { + my $class = shift; + my $caller = caller; + + my %exports; + + my $instance = $class->new; + + $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; + + $exports{stage} = sub { + my ($name, $code) = @_; + my @caller = caller(); + $instance->build_stage( + name => $name, + code => $code, + caller => \@caller, + ); + }; + + $exports{eager} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_eager(1); + }; + + $exports{default} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + my $name = $stage->name; + $instance->set_default_stage($name); + }; + + $exports{file_stage} = sub { + my ($callback) = @_; + my @caller = caller(); + croak "'file_stage' cannot be used under a stage" if @{$instance->stack}; + $instance->add_file_stage(\@caller, $callback); + }; + + for my $name (qw/pre_fork post_fork pre_launch/) { + my $meth = "add_${name}_callback"; + $exports{$name} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->$meth(@_); + }; + } + + $exports{watch} = sub { + if (@{$instance->stack}) { + my $stage = $instance->stack->[-1]; + return $stage->watch(@_); + } + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + return $active->add_callback(@_); + } + } + + croak "No current stage, and no active deptracer"; + }; + + $exports{preload} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->add_to_load_sequence(@_); + }; + + $exports{reload_remove_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_remove_check(@_); + }; + + $exports{reload_inplace_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_inplace_check(@_); + }; + + for my $name (keys %exports) { + no strict 'refs'; + *{"$caller\::$name"} = $exports{$name}; + } +} + +use Test2::Harness::Util::HashBase qw{ + <stage_list + <stage_lookup + <stack + +default_stage + +file_stage +}; + +sub init { + my $self = shift; + + $self->{+STAGE_LIST} //= []; + $self->{+STAGE_LOOKUP} //= {}; + + $self->{+STACK} //= []; + + $self->{+FILE_STAGE} //= []; +} + +sub build_stage { + my $self = shift; + my %params = @_; + + my $caller = $params{caller} //= [caller()]; + + die "A coderef is required at $caller->[1] line $caller->[2].\n" + unless $params{code}; + + my $stage = Test2::Harness::Runner::Preload::Stage->new( + stage_lookup => $self->{+STAGE_LOOKUP}, + %params, + ); + + my $stack = $self->{+STACK} //= []; + push @$stack => $stage; + + my $ok = eval { $params{code}->($stage); 1 }; + my $err = $@; + + die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; + + pop @$stack; + + die $err unless $ok; + + if (@$stack) { + $stack->[-1]->add_child($stage); + } + else { + $self->add_stage($stage, $caller); + } + + return $stage; +} + +sub add_stage { + my $self = shift; + my ($stage, $caller) = @_; + + $caller //= [caller()]; + + my @all = ($stage, @{$stage->all_children}); + + for my $item (@all) { + my $name = $item->name; + + if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { + $caller //= [caller()]; + my $ncaller = $item->frame; + my $ecaller = $existing->frame; + die <<" EOT" +A stage named '$name' was already defined. + First at $ecaller->[1] line $ecaller->[2]. + Second at $ncaller->[1] line $ncaller->[2]. + Mixed at $caller->[1] line $caller->[2]. + EOT + } + + $self->{+STAGE_LOOKUP}->{$name} = $item; + } + + push @{$self->{+STAGE_LIST}} => $stage; +} + +sub merge { + my $self = shift; + my ($merge) = @_; + + my $caller = [caller()]; + + for my $stage (@{$merge->{+STAGE_LIST}}) { + $self->add_stage($stage, $caller); + } + + push @{$self->{+FILE_STAGE}} => @{$merge->{+FILE_STAGE}}; + + $self->{+DEFAULT_STAGE} //= $merge->default_stage; +} + +sub add_file_stage { + my $self = shift; + my ($caller, $code) = @_; + + croak "Caller must be defined and an array" unless $caller && ref($caller) eq 'ARRAY'; + croak "Code must be defined and a coderef" unless $code && ref($code) eq 'CODE'; + + push @{$self->{+FILE_STAGE}} => [$caller, $code]; +} + +sub file_stage { + my $self = shift; + my ($file) = @_; + + for my $cb (@{$self->{+FILE_STAGE}}) { + my ($caller, $code) = @$cb; + my $stage = $code->($file) or next; + + die "file_stage callback returned invalid stage: $stage at $caller->[1] line $caller->[2].\n" + unless $self->{+STAGE_LOOKUP}->{$stage}; + + return $stage; + } + + return; +} + +sub default_stage { + my $self = shift; + return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; + return $self->{+STAGE_LIST}->[0]; +} + +sub set_default_stage { + my $self = shift; + my ($name) = @_; + + croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; + $self->{+DEFAULT_STAGE} = $name; +} + +sub eager_stages { + my $self = shift; + + my %eager; + + for my $root (@{$self->{+STAGE_LIST}}) { + for my $stage ($root, @{$root->all_children}) { + next unless $stage->eager; + $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; + } + } + + return \%eager; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload - DSL for building complex stage-based preload +tools. + +=head1 DESCRIPTION + +L<Test2::Harness> allows you to preload libraries for a performance boost. This +module provides tools that let you go beyond that and build a more complex +preload. In addition you can build multiple preload I<stages>, each stage will +be its own process and tests can run from a specific stage. This allows for +multiple different preload states from which to run tests. + +=head1 SYNOPSIS + +=head2 USING YOUR PRELOAD + +The C<-P> or C<--preload> options work for custom preload modules just as they +do regular modules. Yath will know the difference and act accordingly. + + yath test -PMy::Preload + +=head2 WRITING YOUR PRELOAD + + package My::Preload; + use strict; + use warnings; + + # This imports several useful tools, and puts the necessary meta-data in + # your package to identify it as a special preload. + use Test2::Harness::Runner::Preload; + + # You must specify at least one stage. + stage Moose => sub { + # Preload can be called multiple times, and can load multiple modules + # per call. Order is preserved. + preload 'Moose', 'Moose::Role'; + preload 'Scalar::Util', 'List::Util'; + + # preload can also be given a sub if you have some custom code to run + # at a specific point in the load order + preload sub { + # Do something before loading Try::Tiny + ... + }; + + preload 'Try::Tiny'; + + # Tell the runner to watch this file for changes, if it does change run + # the sub instead of the usual reload process. This lets you reload + # configs and other non-perl files, or allows you to use a custom + # reload sub for perl files. + watch 'path/to/file' => sub { ... }; + + # You can also use watch inside preload subs: + preload sub { + watch 'path/to/file' => sub { ... }; + }; + + # In app code you can add watches dynamically when applicable: + preload sub { + ... # inside app code + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + $active->add_callback('path/to/file' => sub { ... }); + } + } + + ... + }; + + # Eager means tests from nested stages can be run in this stage as + # well, this is useful if the nested stage takes a long time to load as + # it allows yath to start running tests sooner instead of waiting for + # the stage to finish loading. Once the nested stage is loaded tests + # intended for it will start running from it instead. + eager(); + + # default means this stage is the one to use if the test does not + # specify a stage. + default(); + + # These are hooks that let you run arbitrary code at specific points in + # the process. pre_fork happens just before forking to run a test. + # post_fork happens just after forking for a test. pre_launch happens + # as late as possible before the test starts executing (post fork, + # after $0 and other special state are reset). + pre_fork sub { ... }; + post_fork sub { ... }; + pre_launch sub { ... }; + + # Stages can be nested, nested ones build off the previous stage, but + # are in a forked process to avoid contaminating the parent. + stage Types => sub { + preload 'MooseX::Types'; + }; + }; + + # Alternative stage that loads Moo instead of Moose + stage Moo => sub { + preload 'Moo'; + + ... + }; + +=head2 HARNESS DIRECTIVES IN PRELOADS + +If you use a staged preload, and the --reload option, you can add 'CHURN' +directives to files in order to only reload sections you are working on. This +is particularly useful when a file cannot be reloaded in full, or when doing so +is expensive. You can wrap subroutines in the churn directives to have yath +reload only those subroutines. + + sub do_not_reload_this { ... { + + # HARNESS-CHURN-START + + sub reload_this_one { + ... + } + + sub reload_this_one_too { + ... + } + + # HARNESS-CHURN-STOP + + sub this_is_not_reloaded { ... } + +You can put as many churn sections you want in as many preloaded modules as you +want. If a change is detected then only the churn sections will be reloaded. +The churn sections are reloaded by taking the source between the start and stop +markers, and running them in an eval like this: + + eval <<EOT + package MODULE_FROM_FILENAME; + use strict; + use warnings; + no warnings 'redefine'; + #line $line_number $file + $YOUR_CODE + ;1; + EOT + +In most cases this is sufficient to replace the old sub with the new one. If +the automatically determined package is not correct you can add a C<package +FOO;> statement inside the markers. If the strict/warnings settings are not to +your specifications you can add overrides inside the markers. Any valid perl +code can go into the markers. + +B<CAVEATS:> Be aware they do not have their original scope, and that can lead +to problems if you are not paying attention. Variables outside your markers are +not accessible, and lexical variables put inside your markers will be "new" on +each reload, this can cause confusion if you have lexicals used by multiple +subs where some are inside churn blocks and others are not, so best not to do +that. Package variables work a bit better, but any assignment lines are re-run. +So C<our $FOO;> is fine (it does not change the value if it is set) but +C<our $FOO = ...> will reset the var on each reload. + +=head1 EXPORTS + +=over 4 + +=item $meta = TEST2_HARNESS_PRELOAD() + +=item $meta = $class->TEST2_HARNESS_PRELOAD() + +This export provides the meta object, which is an instance of this class. This +method being present is how Test2::Harness differentiates between a regular +module and a special preload library. + +=item stage NAME => sub { ... } + +This creates a new stage with the given C<NAME>, and then runs the coderef with +the new stage set as the I<active> one upon which the other function here will +operate. Once the coderef returns the I<active> stage is cleared. + +You may nest stages by calling this function again inside the codeblock. + +B<NOTE:> stage names B<ARE> case sensitive. This can be confusing when you +consider that most harness directives are all-caps. In the following case the +stage requested by the test and the stage defined in +the library are NOT the same. + +In a test file: + + # HARNESS-STAGE-FOO + +In a preload library: + + stage foo { ... } + +Harness directives are all-caps, however the user data portion need not be, +this is fine: + + # HARNESS-STAGE-foo + +However it is very easy to make the mistake of thinking it is case insensitive. +It is also easy to assume the 'foo' part of the harness directive must be all +caps. In many cases it is smart to make your stage names all-caps. + +=item preload $module_name + +=item preload @module_names + +=item preload sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +This adds modules to the list of libraries to preload. Order is preserved. You +can also add coderefs to execute arbitrary code between module loads. + +The coderef is called with no arguments, and its return is ignored. + +=item eager() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This marks the I<active> stage as being I<eager>. An eager stage will start +running tests for nested stages if it finds itself with no tests of its own to +run before the nested stage can finish loading. The idea here is to avoid +unused test slots when possible allowing for tests to complete sooner. + +=item default() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This B<MUST> be called only once across C<ALL> stages in a given library. + +If multiple preload libraries are loaded then the I<first> default set (based +on load order) will be the default, others will notbe honored. + +=item $stage_name = file_stage($test_file) + +This is optional. If defined this callback will have a chance to look at all +files that are going to be run and assign them a stage. This may return undef +or an empty list if it does not have a stage to assign. + +If multiple preload libraries define file_stage callbacks they will be called +in order, the first one to return a stage name will win. + +If no file_stage callbacks provide a stage for a file then any harness +directives declaring a stage will be honored. If no stage is ever assigned then +the test will be run int he default stage. + +=item pre_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before the preload-stage process forks to run the +test. Note that any state changes here can effect future tests to be run. + +=item post_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just after the preload-stage process forks to run the +test. This is run as early as possible, things like C<$0> may not be set +properly yet. + +=item pre_launch sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before control of the test process is turned over +to the test file itself. This is run as late as possible, so things like C<$0> +should be set properly. + +=back + +=head1 META-OBJECT + +This class is also the meta-object used to construct a preload library. The +methods are left undocumented as this is an implementation detail and you are +not intended to directly use this object. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Runner/Preload/Stage.pm b/lib2.0/Test2/Harness/Runner/Preload/Stage.pm new file mode 100644 index 000000000..c3eae67e6 --- /dev/null +++ b/lib2.0/Test2/Harness/Runner/Preload/Stage.pm @@ -0,0 +1,174 @@ +package Test2::Harness::Runner::Preload::Stage; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::HashBase qw{ + <name + <frame + <children + <pre_fork_callbacks + <post_fork_callbacks + <pre_launch_callbacks + <load_sequence + <watches + eager + reload_remove_check + reload_inplace_check +}; + +sub init { + my $self = shift; + + $self->{+FRAME} //= [caller(1)]; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; + croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; + + $self->{+CHILDREN} //= []; + + $self->{+PRE_FORK_CALLBACKS} //= []; + $self->{+POST_FORK_CALLBACKS} //= []; + $self->{+PRE_LAUNCH_CALLBACKS} //= []; + + $self->{+LOAD_SEQUENCE} //= []; + $self->{+WATCHES} //= {}; +} + +sub watch { + my $self = shift; + my ($file, $callback) = @_; + croak "The first argument must be a file" unless $file && -f $file; + croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; + croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; + + $self->{+WATCHES}->{$file} = $callback; + return; +} + +sub all_children { + my $self = shift; + + my @out = @{$self->{+CHILDREN}}; + + for (my $i = 0; $i < @out; $i++) { + my $it = $out[$i]; + push @out => @{$it->children}; + } + + return \@out; +} + +sub add_child { + my $self = shift; + my ($stage) = @_; + push @{$self->{+CHILDREN}} => $stage; +} + +sub add_pre_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; +} + +sub add_post_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+POST_FORK_CALLBACKS}} => $cb; +} + +sub add_pre_launch_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; +} + +sub add_to_load_sequence { + my $self = shift; + + for my $item (@_) { + croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" + unless ref($item) eq 'CODE' || !ref($item); + + push @{$self->{+LOAD_SEQUENCE}} => $item; + } + + return @_; +} + +sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } +sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } +sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } + +sub load { + my $self = shift; + + for my $item (@{$self->load_sequence // []}) { + my $type = ref($item) // 'file'; + if ($type eq 'CODE') { + $item->(); + } + else { + require(mod2file($item)); + } + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload::Stage - Abstraction of a preload stage. + +=head1 DESCRIPTION + +This is an implementation detail. You are not intended to directly use/modify +instances of this class. See L<Test2::Harness::Runner::Preload> for +documentation on how to write a custom preload library. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Scheduler.pm b/lib2.0/Test2/Harness/Scheduler.pm new file mode 100644 index 000000000..c4e4402e3 --- /dev/null +++ b/lib2.0/Test2/Harness/Scheduler.pm @@ -0,0 +1,1427 @@ +package Test2::Harness::Scheduler; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak confess/; +use List::Util qw/first/; +use Scalar::Util qw/blessed/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/mod2file/; +use Linux::Inotify2; + +use Test2::Harness::Task; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + <run_order + <runs + + <pending + <running + + <run_pid + + <inotify <watch + + done +}; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + $self->{+RUNS} //= {}; + $self->{+PENDING} //= {}; + $self->{+RUNNING} //= {}; + $self->{+RUN_ORDER} //= []; +} + +sub post_data_hook { + my $self = shift; + + my $pending = $self->{+PENDING}; + + for my $run_id (keys %{$pending // {}}) { + for my $test (@{$pending->{$run_id} // []}) { + Test2::Harness::Task->FROM_JSON($test) unless blessed($test); + } + } + + return $self; +} + +sub queue { + my $self = shift; + my ($run_id) = @_; + + $self->transaction(w => sub { + confess "run '$run_id' has already been queued" + if $self->{+RUNS}->{$run_id}; + + confess "Queue has been terminated" + if @{$self->{+RUN_ORDER}} && !defined($self->{+RUN_ORDER}->[-1]); + + push @{$self->{+RUN_ORDER} //= []} => $run_id; + $self->{+RUNS}->{$run_id} = 1; + + my $pending = $self->{+PENDING} //= {}; + + for my $task (@{$self->sort_tasks($self->state->shared_all([task => $run_id]))}) { + if ($task->is_test) { + push @{$pending->{$run_id}} => $task->state_field; + } + else { + $self->state->shared_get('runner', $task->stage)->queue_job($task->state_field); + } + } + }); +} + +sub retry { + my $self = shift; + my ($task) = @_; + + confess "rerun can only be used for test tasks" unless $task->is_test; + + my $run_id = $task->run_id or die "No run id"; + my $run = $self->runs->{$run_id} or confess "Invalid run_id '$run_id', run not found"; + + $task = $task->clone; + $task->increment_try; + + $task->set_category('isolation') if $run->retry_isolated; + + $self->transaction(w => sub { + my $pending = $self->{+PENDING} //= {}; + unshift @{$pending->{$run_id}} => $task->state_field; + }); +} + +my %CAT_ORDER = ( + isolation => 1, + immiscible => 2, + conflicts => 3, + general => 4, +); + +my %DURATION_ORDER = ( + long => 1, + medium => 2, + short => 3, +); + +sub sort_tasks { + my $self = shift; + my ($tasks) = @_; + + @$tasks = sort { + my $out = 0; + + $out ||= $a->is_test <=> $b->is_test; + + # Retries to the front + $out ||= $b->is_try <=> $a->is_try; + + # Smoke early + $out ||= $b->smoke <=> $a->smoke; + + # Categegories by order + $out ||= $CAT_ORDER{$a->category} <=> $CAT_ORDER{$b->category}; + + # More Conflicts means run earlier + $out ||= @{$b->conflicts // []} <=> @{$a->conflicts // []}; + + # Duration if possible + my $ad = $a->duration; + my $bd = $b->duration; + if ($ad && $bd) { + $ad = lc($ad); + $bd = lc($bd); + + if ($DURATION_ORDER{$ad} && $DURATION_ORDER{$bd}) { + $out = $DURATION_ORDER{$ad} <=> $DURATION_ORDER{$bd}; + } + else { + $out = $ad <=> $bd; + } + } + + $out; + } @$tasks; + + return $tasks; +} + +sub terminate_queue { + my $self = shift; + + $self->transaction(w => sub { + return if @{$self->{+RUN_ORDER} // []} && !defined($self->{+RUN_ORDER}->[-1]); + push @{$self->{+RUN_ORDER} //= []} => undef; + }); +} + +sub truncate_queue { + my $self = shift; + my (%params) = @_; + + $self->transaction(w => sub { + $self->{+RUN_ORDER} = []; + $self->{+RUNS} = {}; + $self->{+PENDING} = {}; + + if ($params{terminate}) { + push @{$self->{+RUN_ORDER} //= []} => undef; + $self->{+DONE} = 1; + } + }); +} + +sub before_write { shift->unwatch } +sub after_write { shift->watch } + +sub inotify { + my $self = shift; + $self->{+INOTIFY} //= my $inotify = Linux::Inotify2->new or $self->harness->abort("Could not initialize Linux::Inotify2: $!"); + return $self->{+INOTIFY}; +} + +sub watch { + my $self = shift; + + return $self->{+WATCH} if $self->{+WATCH}; + + print "Adding Watch\n"; + + my $inotify = $self->inotify; + my $harness = $self->state; + $self->{+WATCH} = $inotify->watch($harness->state_file, IN_MODIFY | IN_ONESHOT, sub { $self->iterate($inotify) }) or $harness->abort("Could not watch state file: $!"); + return $self->{+WATCH}; +} + +sub unwatch { + my $self = shift; + + print "Canceling Watch\n"; + + my $watch = $self->{+WATCH} or return; + $watch->cancel; +} + +sub run { + my $self = shift; + + if (my $run_pid = $self->{+RUN_PID}) { + confess "Only pid '$run_pid' can run the scheduler, this is pid '$$'" unless $$ == $run_pid; + confess "Scheduler is already running"; + } + else { + $self->transaction(w => sub { $self->{+RUN_PID} = $$ }); + } + + print "STATE: " . $self->state->state_file . "\n"; + + my $child = 0; + local $SIG{CHLD} = sub { $child++; }; # Required to break inotify poll + + while(1) { + print "LOOP!\n"; + $self->iterate(); + last if $self->done; + $self->inotify->poll; + last if $self->done; + } + + $self->transaction(w => sub { delete $self->{+RUN_PID} }); + + return 0; +} + +sub ready_stages { + my $self = shift; + + my $harness = $self->state; + + my %ready; + + $self->transaction(r => sub { + %ready = map { my $n = $_->stage_name; ($n => $n) } grep { $_->ready } @{$harness->shared_all('runners')}; + }); + + my $base = $harness->shared_get(runner => 'base'); + + my %out; + + # This will iterate all stages and their children. Any ready eager stage + # found will be set as the value of it's child stages in the %out hash. + # This will make the deepest ready-eager stage the assigned value for any + # child stage. + my %seen; + my @todo = @{$base->children}; + while (my $s = shift @todo) { + next if $seen{$s}++; + + my $name = $s->name; + my $e = $s->eager; + + for my $child (@{$s->children}) { + push @todo => $child; + next unless $e && $ready{$name}; + + my $cname = $child->name; + $out{$cname} = $name; + } + } + + # Use our eager stages, but override with ready stages where applicable. + # 'base' is always ready + return {%out, %ready, base => 'base'}; +} + +sub iterate { + my $self = shift; + print "ITERATE\n"; + + my $runner = $self->state->shared_get('runner', 'base'); + + if (!$runner->is_running && defined $runner->exit_code) { + $self->{+DONE} = 1; + return; + } + + return if $self->done; + + $self->refresh; + return if $self->done; + + # If there are no runs to do then we do nothing + my $run_order = $self->run_order; + return unless $run_order && @$run_order; + + # Only run is undef, that means we have terminated the queue, and we have + # completed all runs up until the termination + if (@$run_order && !defined($run_order->[0])) { + $self->{+DONE} = 1; + return; + } + + return unless $self->pending; + my $harness = $self->state; + my $runs = $self->runs; + my @limiters = grep { $_->is_job_limiter || $_->applies_to_all_tests } @{$self->state->shared_all('resources')}; + + my $hit_limit = 0; + my $limited = sub { + return 1 if $hit_limit; + $hit_limit = first { !$_->available } @limiters; + }; + + my $stages = $self->ready_stages; + + for my $run_id (@$run_order) { + last unless $run_id; + return if $limited->(); + + # If any 'isolated' test is running, then we cannot do anything. + last if $self->{+RUNNING}->{categories}->{isolation}; + + my $run = $runs->{$run_id} or confess "No run found for run-id '$run_id'"; + + my $isolation = 0; + + $self->transaction( + w => sub { + my $pending = $self->pending; + my $run_pending = $pending->{$run_id} //= []; + + my @keep; + while (my $task_id = shift @$run_pending) { + push @keep => $task_id; + my $test = $harness->shared_get(@$task_id); + + last if $limited->(); # Do not make this one return. + + $isolation++ if $test->category eq 'isolation'; + + my $spec = $self->can_run($test, $stages) or next; + pop @keep; # We will handle it now + + if (my $unavailable = $spec->{unavailable}) { + use Data::Dumper; + print "SKIP: $test->{file} " . Dumper($spec); + $runner->skip_test($test, $unavailable); + } + else { + print "RUN: $test->{file}\n"; + my $stage = $spec->{stage}; + my $task = $spec->{task}; + print $task->{file} . "\n"; + $self->start_running($task); + my $runner = $self->state->shared_get(runner => $stage); + $runner->queue_task($task); + } + } + + unshift @$run_pending => @keep; + } + ); + + return if $limited->(); + + # Do not progress to the next run if there are isolation tests that + # need to execute. We might never finish this run if we do. + return if $isolation; + } +} + +sub can_run { + my $self = shift; + my ($test, $stages) = @_; + + # Do not run if there is a conflict + my $conflicts = $self->{+RUNNING}->{conflicts}; + return if first { $conflicts->{$_} } @{$test->conflicts}; + + # Do not run if isolation is not right + return if $self->{+RUNNING}->{categories}->{isolation}; + return if $test->category eq 'isolation' && $self->{+RUNNING}->{total}; + + # Do not run if no stage can run it + # We need a list of stages, as well as what stages they can emulate (early-eager) + my $stage = $stages->{$test->stage} or return; + + # Resource check+assignment + my @resources = @{$self->state->shared_all('resource')}; + + my (@free, @busy, @unavailable); + for my $res (@resources) { + next unless $res->is_job_limiter || $res->applies_to_all_tests || $res->applies_to_test($test); + my $av = $res->available_for_test($test); + + if ($av) { # Available + push @free => [$res, $av]; + } + elsif (!defined($av)) { # Will never be available + push @unavailable => $res; + } + else { # Busy, try again + push @busy => $res; + } + } + + return {unavailable => \@unavailable} if @unavailable; + + return if @busy; + + my $env = {}; + for my $res_set (@free) { + my ($res, $av) = @$res_set; + $res->allocate_for_test($test, $av, env => $env); + } + + my $task = $test->clone; + $task->set_env_vars({%{$task->env_vars // {}}, %$env}); + + return {stage => $stage, task => $task}; +} + +sub start_running { + my $self = shift; + my ($task) = @_; + + $self->transaction(w => sub { + $self->{+RUNNING}->{by_job_id}->{$task->job_id} = $task; + $self->{+RUNNING}->{total}++; + $self->{+RUNNING}->{by_run_id}->{$task->run_id}++; + $self->{+RUNNING}->{categories}->{$task->category}++; + $self->{+RUNNING}->{conflicts}->{$_}++ for @{$task->conflicts}; + }); +} + +sub stop_running { + my $self = shift; + my ($task, %params) = @_; + + $self->transaction(w => sub { + delete $self->{+RUNNING}->{by_job_id}->{$task->job_id}; + $self->{+RUNNING}->{total}--; + $self->{+RUNNING}->{by_run_id}->{$task->run_id}--; + $self->{+RUNNING}->{categories}->{$task->category}--; + $self->{+RUNNING}->{conflicts}->{$_}-- for @{$task->conflicts // []}; + + $self->retry($task) if $params{retry}; + }); +} + +sub category_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + my $running = $self->running; + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $running->{categories}->{immiscible}; + + # Only search isolation if nothing is running. + unshift @cat_order => 'isolation' unless $running->{total}; + + return \@cat_order; +} + +sub TO_JSON { + my $self = shift; + my $out = $self->SUPER::TO_JSON(); + delete $out->{+INOTIFY}; + delete $out->{+WATCH}; + return $out; +} + +1; + +__END__ + + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +package Test2::Harness::Runner::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::State; + +use Test2::Harness::Settings; +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run; +use Test2::Harness::Util::Queue; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase( + # These are construction arguments + qw{ + <eager_stages + <state + <workdir + <preloader + <no_poll + <resources + job_count + +settings + }, + + qw{ + <dispatch_file + <queue_ended + + <pending_tasks <task_lookup + <pending_runs +run <stopped_runs + <pending_spawns + + <running + <running_categories + <running_durations + <running_conflicts + <running_tasks + + <stage_readiness + + <task_list + + <halted_runs + + <reload_state + + <observe + }, +); + +sub init { + my $self = shift; + + croak "You must specify a workdir or provide state" + unless $self->{+STATE} || defined $self->{+WORKDIR}; + + $self->{+WORKDIR} //= $self->{+STATE}->workdir; + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; + + if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { + my $settings = $self->settings; + my $resources = $self->{+RESOURCES} //= []; + for my $res (@{$self->settings->runner->resources}) { + require(mod2file($res)); + push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); + } + } + + unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { + require Test2::Harness::Runner::Resource::JobCount; + push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); + } + + @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; + + $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); + + $self->{+RELOAD_STATE} //= {}; + + $self->poll; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->state->settings; +} + +sub run { + my $self = shift; + return $self->{+RUN} if $self->{+RUN}; + $self->poll(); + return $self->{+RUN}; +} + +sub done { + my $self = shift; + + $self->poll(); + + return 0 if $self->{+RUNNING}; + return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; + + return 0 if $self->{+RUN}; + return 0 if @{$self->{+PENDING_RUNS} //= []}; + + return 0 unless $self->{+QUEUE_ENDED}; + + return 1; +} + +sub next_task { + my $self = shift; + my ($stage) = @_; + + $self->poll(); + $self->clear_finished_run(); + + while(1) { + if (@{$self->{+PENDING_SPAWNS} //= []}) { + my $spawn = shift @{$self->{+PENDING_SPAWNS}}; + next unless $spawn->{stage} eq $stage; + $self->start_spawn($spawn); + return $spawn; + } + + my $task = shift @{$self->{+TASK_LIST}} or return undef; + + # If we are replaying a state then the task may have already completed, + # so skip it if it is not in the running lookup. + next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; + next unless $task->{stage} eq $stage; + + return $task; + } +} + +sub advance { + my $self = shift; + $self->poll(); + + $_->tick() for @{$self->{+RESOURCES} //= []}; + + $self->advance_run(); + return 0 unless $self->{+RUN}; + return 1 if $self->advance_tasks(); + return $self->clear_finished_run(); +} + +my %ACTIONS = ( + queue_run => '_queue_run', + queue_task => '_queue_task', + queue_spawn => '_queue_spawn', + start_spawn => '_start_spawn', + start_run => '_start_run', + start_task => '_start_task', + stop_run => '_stop_run', + stop_task => '_stop_task', + retry_task => '_retry_task', + stage_ready => '_stage_ready', + stage_down => '_stage_down', + end_queue => '_end_queue', + halt_run => '_halt_run', + truncate => '_truncate', + reload => '_reload', +); + +sub poll { + my $self = shift; + + return if $self->{+NO_POLL}; + + my $queue = $self->dispatch_file; + + for my $item ($queue->poll) { + my $data = $item->[-1]; + my $item = $data->{item}; + my $action = $data->{action}; + my $pid = $data->{pid}; + + my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; + + $self->$sub($item, $pid); + } +} + +sub _enqueue { + my $self = shift; + my ($action, $item) = @_; + $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); + $self->poll; +} + +sub truncate { + my $self = shift; + $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; + $self->_enqueue(truncate => $$); + $self->poll; +} + +sub _truncate { } + +sub end_queue { $_[0]->_enqueue('end_queue' => 1) } +sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } + +sub halt_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(halt_run => $run_id); + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run_id}; + $data->jobs->{$run_id}->{closed} = 1; + }); +} + +sub _halt_run { + my $self = shift; + my ($run_id) = @_; + + delete $self->{+PENDING_TASKS}->{$run_id}; + + $self->{+HALTED_RUNS}->{$run_id}++; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + $self->_enqueue(queue_run => $run); +} + +sub _queue_run { + my $self = shift; + my ($run) = @_; + + push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( + %$run, + workdir => $self->{+WORKDIR}, + state => $self->{+STATE}, + ); + + return; +} + +sub start_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(start_run => $run_id); +} + +sub _start_run { + my $self = shift; + my ($run_id) = @_; + + my $run = shift @{$self->{+PENDING_RUNS}}; + die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; + die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; + + $self->{+RUN} = $run; + + return; +} + +sub stop_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(stop_run => $run_id); +} + +sub _stop_run { + my $self = shift; + my ($run_id) = @_; + + $self->{+STOPPED_RUNS}->{$run_id} = 1; + + return; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + $spawn->{spawn} //= 1; + $spawn->{id} //= gen_uuid(); + $self->_enqueue(queue_spawn => $spawn); +} + +sub _queue_spawn { + my $self = shift; + my ($spawn) = @_; + + $spawn->{id} //= gen_uuid(); + $spawn->{spawn} //= 1; + $spawn->{use_preload} //= 1; + + $spawn->{stage} //= 'default'; + $spawn->{stage} = $self->task_stage($spawn); + + push @{$self->{+PENDING_SPAWNS}} => $spawn; + + return; +} + +sub start_spawn { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_spawn => $spec); +} + +sub _start_spawn { + my $self = shift; + my ($spec) = @_; + + my $uuid = $spec->{id} or die "Could not find UUID for spawn"; + + @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; + + return; +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + $self->_enqueue(queue_task => $task); +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + my $job_id = $task->{job_id} or die "Task missing job_id"; + my $run_id = $task->{run_id} or die "Task missing run_id"; + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + +sub start_task { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_task => $spec); +} + +sub _start_task { + my $self = shift; + my ($spec) = @_; + + my $job_id = $spec->{job_id} or die "No job_id provided"; + my $run_stage = $spec->{stage} or die "No stage provided"; + my $res = $spec->{res} or die "No res provided"; + my $res_skip = $spec->{resource_skip}; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; + my $count = @$set; + @$set = grep { $_->{job_id} ne $job_id } @$set; + die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; + + $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); + + # Set the stage, new task hashref + $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; + + $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + push @{$task->{test_args}} => @{$res->{args}}; + + for my $resource (@{$self->{+RESOURCES}}) { + my $class = ref($resource); + my $val = $res->{record}->{$class} // next; + $resource->record($task->{job_id}, $val); + } + + die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; + $self->{+RUNNING_TASKS}->{$job_id} = $task; + + $task->{resource_skip} = $res_skip if $res_skip; + + push @{$self->{+TASK_LIST}} => $task; + + $self->{+RUNNING}++; + $self->{+RUNNING_CATEGORIES}->{$cat}++; + $self->{+RUNNING_DURATIONS}->{$dur}++; + + my $cfls = $task->{conflicts} //= []; + for my $cfl (@$cfls) { + die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" + if $self->{+RUNNING_CONFLICTS}->{$cfl}++; + } + + return; +} + +sub stop_task { + my $self = shift; + my ($job_id) = @_; + $self->_enqueue(stop_task => $job_id); +} + +sub _stop_task { + my $self = shift; + my ($job_id) = @_; + + my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; + + delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; + + $_->release($job_id) for @{$self->{+RESOURCES}}; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + $self->{+RUNNING}--; + $self->{+RUNNING_CATEGORIES}->{$cat}--; + $self->{+RUNNING_DURATIONS}->{$dur}--; + + my $cfls = $task->{conflicts} //= []; + $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; + + return; +} + +sub retry_task { + my $self = shift; + my ($job_id) = @_; + + $self->_enqueue(retry_task => $job_id); +} + +sub _retry_task { + my $self = shift; + my ($job_id) = @_; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; + + $self->_stop_task($job_id); + + return if $self->{+HALTED_RUNS}->{$task->{run_id}}; + + $task = {is_try => 0, %$task}; + $task->{is_try}++; + $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; + + $self->_queue_task($task); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_ready => $stage); +} + +sub _stage_ready { + my $self = shift; + my ($stage, $pid) = @_; + + $self->{+STAGE_READINESS}->{$stage} = $pid // 1; + + return; +} + +sub stage_down { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_down => $stage); +} + +sub _stage_down { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE_READINESS}->{$stage} = 0; + + return; +} + +sub reload { + my $self = shift; + my ($stage, $data) = @_; + $stage //= 'default'; + $self->_enqueue(reload => {%$data, stage => $stage}); + return; +} + +sub _reload { + my $self = shift; + my ($data) = @_; + + my $stage = $data->{stage}; + my $file = $data->{file}; + my $success = $data->{reloaded}; + my $error = $data->{error}; + my $warnings = $data->{warnings}; + + my $reload_state = $self->{+RELOAD_STATE} //= {}; + my $stage_state = $reload_state->{$stage} //= {}; + + # It either succeeded, or the stage will be reloaded, no need to track brokenness + if (defined $success) { + delete $stage_state->{$file}; + } + else { + my $fields = {}; + $fields->{error} = $error if defined($error) && length($error); + $fields->{warnings} = $warnings if $warnings && @{$warnings}; + + if (keys %$fields) { + $stage_state->{$file} = $fields; + } + else { + delete $stage_state->{$file}; + } + } + + return; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + return $wants if $self->{+NO_POLL}; + + return $wants // 'DEFAULT' unless $self->preloader; + return $self->preloader->task_stage($task->{file}, $wants); +} + +sub task_pending_lookup { + my $self = shift; + my ($task) = @_; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; +} + +sub task_fields { + my $self = shift; + my ($task) = @_; + + my $run_id = $task->{run_id} or die "No run id provided by task"; + my $smoke = $task->{smoke} ? 'smoke' : 'main'; + my $stage = $self->task_stage($task); + + my $cat = $task->{category}; + my $dur = $task->{duration}; + + die "Invalid category: $cat" unless CATEGORIES->{$cat}; + die "Invalid duration: $dur" unless DURATIONS->{$dur}; + + $cat = 'conflicts' if $cat eq 'general' && $task->{conflicts} && @{$task->{conflicts}}; + + return ($run_id, $smoke, $stage, $cat, $dur); +} + +sub advance_run { + my $self = shift; + + return 0 if $self->{+RUN}; + + return 0 unless @{$self->{+PENDING_RUNS} //= []}; + $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); + + return 1; +} + +sub clear_finished_run { + my $self = shift; + + my $run = $self->{+RUN} or return 0; + + return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; + return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; + return 0 if $self->{+RUNNING}; + + delete $self->{+RUN}; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run->run_id}; + $data->jobs->{$run->run_id}->{closed} = 1; + }); + + return 1; +} + +sub advance_tasks { + my $self = shift; + + for my $resource (@{$self->{+RESOURCES}}) { + $resource->refresh(); + + next unless $resource->job_limiter; + return 0 if $resource->job_limiter_at_max(); + } + + my ($run_stage, $task, $res, %params) = $self->_next(); + + my $out = 0; + if ($task) { + $out = 1; + $self->start_task({job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}); + } + + $_->discharge() for @{$self->{+RESOURCES}}; + + return $out; +} + +sub _cat_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; + + # Only search isolation if nothing is running. + push @cat_order => 'isolation' unless $self->{+RUNNING}; + + return \@cat_order; +} + +sub _dur_order { + my $self = shift; + + my $max = 0; + for my $resource (@{$self->resources}) { + next unless $resource->job_limiter; + my $val = $resource->job_limiter_max; + $max = $val if !$max || $val < $max; + } + $max //= 1; + + my $maxm1 = $max - 1; + + my $durs = $self->{+RUNNING_DURATIONS}; + + # 'short' is always ok. + my @dur_order = ('short'); + + # long and medium should be on the front of the search unless we are + # already running (max - 1) tests of the duration We want long first if + # we are not saturation on them, followed by medium, whcih is why they + # are listed in this order. + for my $c (qw/medium long/) { + if ($durs->{$c} && $durs->{$c} >= $maxm1) { + push @dur_order => $c; # Back of the list + } + else { + unshift @dur_order => $c; # Front of the list + } + } + + return \@dur_order; +} + +# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in +# which we search for tasks, 'RUN_STAGE' is the stage that actually does the +# work. This is what allows us to find tasks for 'eager' stages that are bored. +sub _stage_order { + my $self = shift; + + my $stage_check = $self->{+STAGE_READINESS} //= {}; + + my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; + + # Populate list with all ready stages + my %seen; + my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; + + # Add in any eager stages, but make sure they are last. + for my $rstage (@stage_list) { + next unless exists $self->{+EAGER_STAGES}->{$rstage}; + push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; + } + + return \@stages; +} + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::State - State tracking for the runner. + +=head1 DESCRIPTION + +This module tracks the state for all running tests. This entire module is +considered an "Implementation Detail". Please do not rely on it always staying +the same, or even existing in the future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Task.pm b/lib2.0/Test2/Harness/Task.pm new file mode 100644 index 000000000..b5f0007a7 --- /dev/null +++ b/lib2.0/Test2/Harness/Task.pm @@ -0,0 +1,850 @@ +package Test2::Harness::Task; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/confess/; +use Test2::Harness::Util qw/mod2file/; + +use parent 'Test2::Harness::Util::IPC::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + stage + category + switches + run_id + env_vars +}; + +sub is_test { 0 } + +sub init { + my $self = shift; + + confess "'run_id' is a required attribute" unless $self->{+RUN_ID}; + $self->SUPER::init(); + + $self->{+STAGE} //= 'base'; + $self->{+CATEGORY} //= 'general'; + $self->{+SWITCHES} //= []; + $self->{+ENV_VARS} //= {}; +} + +sub clone { + my $self = shift; + my $class = ref($self); + + my $new = { %$self }; + $new->{+ENV_VARS} = { %{ $self->{+ENV_VARS} // {} } }; + + return bless($new, $class); +} + +sub FROM_JSON { + my $class = shift; + my ($data) = @_; + $class = delete $data->{class} if defined $data->{class}; + require(mod2file($class)); + bless($data, $class); +} + +1; + +__END__ + + + + + +via + +tmp_dir + +ch_dir + +unsafe_inc + + +use_fork + +use_w_switch + + +includes + +use_stream + + +args + + +file +run_file + + +load +load_import + + +event_uuids +mem_usage +io_events + + +env_vars + + +event_timeout +post_exit_timeout +use_timeout + + +switches_from_env + + +et_file +pet_file + + +min_slots + +max_slots + } +); + +sub category { 'job' } + +sub init { + my $self = shift; + + croak "'runner' is a required attribute" unless $self->{+RUNNER}; + croak "'run' is a required attribute" unless $self->{+RUN}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + delete $self->{+JOB_DIR}; + + # Avoid a ref cycle + #weaken($self->{+RUNNER}); + + my $task = $self->{+TASK} or croak "'task' is a required attribute"; + + delete $self->{+LAST_OUTPUT_SIZE}; + + confess "Task does not have a job ID" unless $task->{job_id}; + confess "Task does not have a file" unless $task->{file}; +} + +sub job_id { $_[0]->{+TASK}->{job_id} } + +sub prepare_dir { + my $self = shift; + + $self->job_dir(); + $self->tmp_dir(); + $self->event_dir(); +} + +sub via { + my $self = shift; + + return undef if $self->{+SETTINGS}->debug->dummy; + return undef if $self->{+TASK}->{resource_skip}; + + return $self->{+VIA} if exists $self->{+VIA}; + + my $task = $self->{+TASK}; + return $self->{+VIA} = $task->{via} if $task->{via}; + + return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork; + + return $self->{+VIA} = undef; +} + +sub spawn_params { + my $self = shift; + + my $task = $self->{+TASK}; + + my $skip; + $skip = 'dummy mode' if $self->{+SETTINGS}->debug->dummy; + $skip = "Some resources are not available: " . join(', ' => @{$self->{+TASK}->{resource_skip}}) if $self->{+TASK}->{resource_skip}; + + my $command; + if (!$skip && $task->{binary} || $task->{non_perl}) { + my $file = $self->ch_dir ? $self->file : $self->rel_file; + $command = [clean_path($file), $self->args]; + } + else { + $command = [ + $^X, + $self->cli_includes, + $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (), + $self->switches, + $self->cli_options, + + $skip ? ('-e', "print \"1..0 # SKIP $skip\"") : (sub { $self->run_file }), + + $self->args, + ]; + } + + my $out_fh = open_file($self->out_file, '>'); + my $err_fh = open_file($self->err_file, '>'); + my $in_fh = open_file($self->in_file, '<'); + + return { + command => $command, + stdin => $in_fh, + stdout => $out_fh, + stderr => $err_fh, + chdir => $self->ch_dir(), + env => $self->env_vars(), + }; +} + +sub switches_from_env { + my $self = shift; + + return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV}; + + return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES}; + + return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]}; +} + +my %JSON_SKIP = ( + SETTINGS() => 1, + TASK() => 1, + RUNNER() => 1, + RUN() => 1, + CLI_INCLUDES() => 1, + CLI_OPTIONS() => 1, + ERR_FILE() => 1, + ET_FILE() => 1, + EVENT_DIR() => 1, + EXIT() => 1, + EXIT_TIME() => 1, + IN_FILE() => 1, + JOB_DIR() => 1, + LAST_OUTPUT_SIZE() => 1, + OUT_FILE() => 1, + BAIL_FILE() => 1, + OUTPUT_CHANGED() => 1, + PET_FILE() => 1, + RUN_DIR() => 1, + TMP_DIR() => 1, +); + +sub TO_JSON { + my $self = shift; + + my $out = { %{$self->{+TASK}} }; + + for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) { + next if $JSON_SKIP{$attr}; + $self->$attr unless defined $self->{$attr}; + $out->{$attr} = $self->{$attr}; + } + + delete $out->{+FORK_CALLBACK}; + delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE'; + + $out->{job_name} //= $out->{job_id}; + $out->{abs_file} = clean_path($self->file); + + return $out; +} + +sub run_file { + my $self = shift; + return $self->{+RUN_FILE} //= $self->rel_file; +} + +sub rel_file { File::Spec->abs2rel($_[0]->file) } +sub file { $_[0]->{+FILE} //= clean_path($_[0]->{+TASK}->{file}, 0) } +sub err_file { $_[0]->{+ERR_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) } +sub out_file { $_[0]->{+OUT_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) } +sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) } +sub et_file { $_[0]->{+ET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) } +sub pet_file { $_[0]->{+PET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) } +sub run_dir { $_[0]->{+RUN_DIR} //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) } + +sub bailed_out { + my $self = shift; + + if(-f $self->bail_file) { + my $fh = open_file($self->bail_file, '<'); + my $reason = <$fh> || 1; + return $reason; + } + + my $fh = open_file($self->out_file, '<'); + while (my $line = <$fh>) { + next unless $line =~ m/^Bail out!\s*(.*)$/; + return $1 || 1; + } + + return ""; +} + +sub output_size { + my $self = shift; + + my $size = 0; + + $size += -s $self->err_file || 0; + $size += -s $self->out_file || 0; + + return $self->{+LAST_OUTPUT_SIZE} = $size; +} + +sub output_changed { + my $self = shift; + + my $last = $self->{+LAST_OUTPUT_SIZE}; + my $size = $self->output_size(); + + # Output changed, update time + return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last; + + # Return the last recorded time, if there is no previously recorded time then the record starts now + return $self->{+OUTPUT_CHANGED} //= time(); +} + +sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 } +sub is_try { $_[0]->{+IS_TRY} //= $_[0]->{+TASK}->{is_try} // 0 } +sub ch_dir { $_[0]->{+CH_DIR} //= $_[0]->{+TASK}->{ch_dir} // '' } +sub unsafe_inc { $_[0]->{+UNSAFE_INC} //= $_[0]->{+RUNNER}->unsafe_inc } +sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids } +sub mem_usage { $_[0]->{+MEM_USAGE} //= $_[0]->run->mem_usage } + +sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) } + +sub smoke { $_[0]->{+SMOKE} //= $_[0]->_fallback(smoke => 0, qw/task/) } +sub retry_isolated { $_[0]->{+RETRY_ISOLATED} //= $_[0]->_fallback(retry_isolated => 0, qw/task run/) } +sub use_stream { $_[0]->{+USE_STREAM} //= $_[0]->_fallback(use_stream => 1, qw/task run/) } +sub use_timeout { $_[0]->{+USE_TIMEOUT} //= $_[0]->_fallback(use_timeout => 1, qw/task/) } +sub retry { $_[0]->{+RETRY} //= $_[0]->_fallback(retry => undef, qw/task run/) } +sub event_timeout { $_[0]->{+EVENT_TIMEOUT} //= $_[0]->_fallback(event_timeout => undef, qw/task runner/) } +sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) } + +sub min_slots { $_[0]->{+MIN_SLOTS} //= $_[0]->_fallback_non_bool(min_slots => 1, qw/task/) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_fallback_non_bool(max_slots => 1, qw/task/) } + +sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} } +sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} } + +sub cli_includes { + my $self = shift; + + # '.' is handled via the PERL_USE_UNSAFE_INC env var set later + $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes]; + + return @{$self->{+CLI_INCLUDES}}; +} + +sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} } + +sub _merge_sources { + my $self = shift; + my ($name, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + next unless defined $val; + next unless @$val; + push @vals => @$val; + } + + return \@vals; +} + +sub _fallback_non_bool { + my $self = shift; + my ($name, $default, @from) = @_; + + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + return $val if defined $val; + } + + return $default; +} + +sub _fallback { + my $self = shift; + my ($name, $default, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + push @vals => $val if defined $val; + } + + return $default unless @vals; + + # If the default is a ref we will just return the first value we found, truthiness check is useless + return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/; + + # If the default is true, then we only return true if none of the vals are false + return !grep { !$_ } @vals if $default; + + # If the default is false, then we return true if any of the valse are true + return grep { $_ } @vals; +} + +sub job_dir { + my $self = shift; + return $self->{+JOB_DIR} if $self->{+JOB_DIR}; + + my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try); + mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!"; + chmod_tmp($job_dir); + $self->{+JOB_DIR} = $job_dir; +} + +sub tmp_dir { + my $self = shift; + + return $self->{+TMP_DIR} if $self->{+TMP_DIR}; + + my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir); + chmod_tmp($tmp_dir); + + $self->{+TMP_DIR} = clean_path($tmp_dir); +} + +sub make_event_dir { $_[0]->event_dir } +sub event_dir { + my $self = shift; + return $self->{+EVENT_DIR} if $self->{+EVENT_DIR}; + + my $events_dir = File::Spec->catdir($self->job_dir, 'events'); + unless (-d $events_dir) { + mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!"; + } + $self->{+EVENT_DIR} = $events_dir; +} + +sub in_file { + my $self = shift; + return $self->{+IN_FILE} if $self->{+IN_FILE}; + + my $task = $self->{+TASK}; + + unless ($task->{input}) { + my $from_run = $self->run->input_file; + return $self->{+IN_FILE} = $from_run if $from_run; + } + + my $stdin = File::Spec->catfile($self->job_dir, 'stdin'); + + my $content = $task->{input} // $self->run->input // ''; + write_file($stdin, $content); + + return $self->{+IN_FILE} = $stdin; +} + +sub use_fork { + my $self = shift; + + return $self->{+USE_FORK} if defined $self->{+USE_FORK}; + + my $task = $self->{+TASK}; + + return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK; + return $self->{+USE_FORK} = 0 if $task->{binary}; + return $self->{+USE_FORK} = 0 if $task->{non_perl}; + return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork}; + return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload}; + + # -w switch is ok, otherwise it is a no-go + return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches; + + my $runner = $self->{+RUNNER}; + return $self->{+USE_FORK} = 0 unless $runner->use_fork; + + return $self->{+USE_FORK} = 1; +} + +sub includes { + my $self = shift; + + return @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + $self->{+INCLUDES} = [ + process_includes( + list => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + $self->ch_dir ? (ch_dir => $self->ch_dir) : (), + ) + ]; + + return @{$self->{+INCLUDES}}; +} + +sub cli_options { + my $self = shift; + + my $event_dir = $self->event_dir; + my $job_id = $self->job_id; + + return ( + $self->use_stream ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (), + $self->event_uuids ? ('-MTest2::Plugin::UUID') : (), + $self->mem_usage ? ('-MTest2::Plugin::MemUsage') : (), + $self->io_events ? ('-MTest2::Plugin::IOEvents') : (), + (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import), + (map { "-m$_" } $self->load), + ); +} + +sub switches { + my $self = shift; + + return @{$self->{+SWITCHES}} if $self->{+SWITCHES}; + + my @switches; + + my %seen; + for my $s (@{$self->{+TASK}->{switches} // []}) { + $seen{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + my %seen2; + for my $s (@{$self->{+RUNNER}->switches // []}) { + next if $seen{$s}; + $seen2{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + for my $s ($self->switches_from_env) { + next if $seen{$s}; + next if $seen2{$s}; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + return @{$self->{+SWITCHES} = \@switches}; +} + +sub prof_file { + my $self = shift; + my $file =$self->rel_file; + + $file =~ s{/}{-}g; + $file =~ s{\.[^\.]+$}{.nytprof}g; + + return $file; +} + +sub env_vars { + my $self = shift; + + return $self->{+ENV_VARS} if $self->{+ENV_VARS}; + + my $from_run = $self->run->env_vars; + my $from_task = $self->{+TASK}->{env_vars}; + + my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB}); + push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl}; + push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB}; + my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l; + + my $verbose = $self->verbose; + + return $self->{+ENV_VARS} = { + $from_run ? (%$from_run) : (), + $from_task ? (%$from_task) : (), + + $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (), + + $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (), + + PERL5LIB => $p5l, + PERL_USE_UNSAFE_INC => $self->unsafe_inc, + TEST2_JOB_DIR => $self->job_dir, + TEST2_RUN_DIR => $self->run_dir, + TMPDIR => $self->tmp_dir, + TEMPDIR => $self->tmp_dir, + SYSTEM_TMPDIR => $self->{+SETTINGS}->harness->orig_tmp, + SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms, + + HARNESS_IS_VERBOSE => $verbose, + T2_HARNESS_IS_VERBOSE => $verbose, + + HARNESS_ACTIVE => 1, + TEST2_HARNESS_ACTIVE => 1, + + T2_HARNESS_JOB_FILE => $self->rel_file, + T2_HARNESS_JOB_NAME => $self->{+TASK}->{job_name}, + T2_HARNESS_JOB_IS_TRY => $self->{+IS_TRY} // 0, + T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '', + }; +} + +sub load_import { + my $self = shift; + + return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT}; + + my $from_run = $self->run->load_import; + + my @out; + for my $mod (@{$from_run->{'@'} // []}) { + push @out => [$mod, $from_run->{$mod} // []]; + } + + return @{$self->{+LOAD_IMPORT} = \@out}; +} + +sub use_w_switch { + my $self = shift; + return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH}; + $self->switches; + return $self->{+USE_W_SWITCH}; +} + +sub set_exit { + my $self = shift; + my ($runner, $exit, $time, @args) = @_; + + $self->SUPER::set_exit(@_); + + my $file = File::Spec->catfile($self->job_dir, 'exit'); + + my $e = parse_exit($exit); + + write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Job - Representation of a test job. + +=head1 DESCRIPTION + +This module takes all the data from a test file queue item, a run, and runner +settings, and mashes them together to figure out what is actually needed to run +a job. + +=head1 METHODS + +Note, this object subclasses L<Test2::Harness::IPC::Process>. + +=over 4 + +=item $arrayref = $job->args + +Get the arguments for the test either formt he queue item, or from the run. + +=item $path = $job->bail_file + +Path to the events-file used in case of a bail-out + +=item $bool = $job->bailed_out + +True if the test job bailed out. + +=item $cat $job->category + +Process category, always 'job' unless overriden in a subclass. + +=item $path = $job->ch_dir + +If this job first requires a change in directory before running, this will +return the path. + +=item @list = $job->cli_includes + +List of includes for a command line launch of this job. + +=item @list = $job->cli_options + +List of options for a command line launch of this job. + +=item $hashref = $job->env_vars + +Get environment variables to set when launching this job. + +=item $path = $job->out_file + +File to which all STDOUT for the job will be written. + +=item $path = $job->err_file + +File to which all STDERR for the job will be written. + +=item $path = $job->et_file + +File to which event timeout notifications will be written. + +=item $path = $job->pet_file + +File to which post exit timeout events will be written. + +=item $path = $job->event_dir + +Directory to which L<Test2::Formatter::Stream> events will be written. + +=item $time = $job->event_timeout + +Event timeout specification, if any, first from test queue item, then from +runner. + +=item $time = $job->post_exit_timeout + +Post exit timeout specification, if any, first from test queue item, then from +runner. + +=item $bool = $job->event_uuids + +Use L<Test2::Plugin::UUID> inside the test. + +=item $path = $job->file + +Test file the job will be running. + +=item $coderef = $job->fork_callback + +If the job is to be launched via fork, use this callback. + +=item $path = $job->in_file + +File containing STDIN to be provided to the test. + +=item @list = $job->includes + +Paths to add to @INC for the test. + +=item $bool = $job->io_events + +True if L<Test2::Plugin::IOEvents> should be used. + +=item $int = $job->is_try + +This starts at 0 and will be incremented for every retry of the job. + +=item $path = $job->job_dir + +Temporary directory housing all files related to this job when it runs. + +=item $uuid = $job->job_id + +UUID for this job. + +=item @list = $job->load + +Modules to load when starting this job. + +=item @list = $job->load_import + +Modules to load and import when starting this job. + +=item $bool = $job->mem_usage + +True if the L<Test2::Plugin::MemUsage> plugin should be used. + +=item $path = $job->run_file + +Usually the same as rel_file, but you can specify an alternative file to +actually run. + +=item $path = $job->rel_file + +Relative path to the file. + +=item $int = $job->retry + +How many times the test should be retried if it fails. + +=item $bool = $job->retry_isolated + +True if the test should be retried in isolation if it fails. + +=item $run = $job->run + +The L<Test2::Harness::Runner::Run> instance. + +=item $path = $job->run_dir + +Path to the temporary directory housing all the data about the run. + +=item $runner = $job->runner + +The L<Test2::Harness::Runner> instance. + +=item @list = $job->runner_includes + +Search path includes provided directly by the runner. + +=item $settings = $job->settings + +The L<Test2::Harness::Settings> instance. + +=item $bool = $job->smoke + +True if the test is a priority smoke test. + +=item $hashref = $job->spawn_params + +Parameters for C<run_cmd()> in L<Test2::Harness::Util::IPC> when launching this +job. + +=item @list = $job->switches + +Command line switches for perl when running this test. + +=item $hashref = $job->task + +Task data from the queue. + +=item $path = $job->tmp_dir + +Temp dir created specifically for this job. + +=item $bool = $job->unsafe_inc + +True if '.' should be added to C<@INC>. + +=item $bool = $job->use_fork + +True if this job should be launched via fork. + +=item $bool = $job->use_stream + +True if this job should use L<Test2::Formatter::Stream>. + +=item $bool = $job->use_timeout + +True if this job should timeout due to lack of activity. + +=item $bool = $job->use_w_switch + +True if the C<-w> switch should be used for this test. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Task/TestFile.pm b/lib2.0/Test2/Harness/Task/TestFile.pm new file mode 100644 index 000000000..4b8624a73 --- /dev/null +++ b/lib2.0/Test2/Harness/Task/TestFile.pm @@ -0,0 +1,754 @@ +package Test2::Harness::Task::TestFile; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; + +use Time::HiRes qw/time/; + +use List::Util 1.45 qw/uniq/; + +use Test2::Harness::Util qw/open_file clean_path/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use File::Spec; + +use parent 'Test2::Harness::Task'; +use Test2::Harness::Util::HashBase qw{ + conflicts + duration + event_timeout + is_try + max_slots + min_slots + post_exit_timeout + retry + retry_isolated + smoke + job_id +}; + +sub is_test { 1 } + +sub increment_try { shift->{+IS_TRY}++ } + +sub clone { + my $self = shift; + + my $new = $self->SUPER::clone(); + + $new->{+CONFLICTS} = [ @{$self->{+CONFLICTS} // []} ]; + + return $new; +} + +sub init { + my $self = shift; + $self->SUPER::init(); + + $self->{+JOB_ID} //= gen_uuid(); + + $self->{+CONFLICTS} //= []; + $self->{+DURATION} //= 'medium'; + $self->{+EVENT_TIMEOUT} //= undef; + $self->{+IS_TRY} //= 0; + $self->{+MAX_SLOTS} //= 1; + $self->{+MIN_SLOTS} //= 1; + $self->{+POST_EXIT_TIMEOUT} //= undef; + $self->{+RETRY_ISOLATED} //= 0; + $self->{+RETRY} //= 0; + $self->{+SMOKE} //= 0; +} + +sub resource_id { + my $self = shift; + return join '~' => @{$self}{qw/job_id is_try/}; +} + +1; + +__END__ + + + <file +relative <_scanned <_headers +_shbang <is_binary <non_perl + input env_vars test_args + queue_args + job_class + comment + _category _stage _duration _min_slots _max_slots +}; + +sub set_duration { $_[0]->set__duration(lc($_[1])) } +sub set_category { $_[0]->set__category(lc($_[1])) } + +sub set_stage { $_[0]->set__stage($_[1]) } +sub set_min_slots { $_[0]->set__min_slots($_[1]) } +sub set_max_slots { $_[0]->set__max_slots($_[1]) } + +sub retry { $_[0]->headers->{retry} } +sub set_retry { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry} = $val; +} + +sub retry_isolated { $_[0]->headers->{retry_isolated} } +sub set_retry_isolated { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry_isolated} = $val; +} + +sub set_smoke { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{features}->{smoke} = $val; +} + +sub init { + my $self = shift; + + my $file = $self->file; + + # We want absolute path + $file = clean_path($file, 0); + $self->{+FILE} = $file; + + $self->{+QUEUE_ARGS} ||= []; + + croak "Invalid test file '$file'" unless -f $file; + + if($self->{+IS_BINARY} = -B $file && !-z $file) { + $self->{+NON_PERL} = 1; + die "Cannot run binary test file '$file': file is not executable.\n" + unless $self->is_executable; + } +} + +sub relative { + my $self = shift; + return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE}); +} + +my %DEFAULTS = ( + timeout => 1, + fork => 1, + preload => 1, + stream => 1, + run => 1, + isolation => 0, + smoke => 0, + io_events => 1, +); + +sub check_feature { + my $self = shift; + my ($feature, $default) = @_; + + $default = $DEFAULTS{$feature} unless defined $default; + + return $default unless defined $self->headers->{features}->{$feature}; + return 1 if $self->headers->{features}->{$feature}; + return 0; +} + +sub check_stage { + my $self = shift; + + return $self->{+_STAGE} if $self->{+_STAGE}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{stage} || undef; +} + +sub check_min_slots { + my $self = shift; + + return $self->{+_MIN_SLOTS} if $self->{+_MIN_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{min_slots} // undef; +} + +sub check_max_slots { + my $self = shift; + + return $self->{+_MAX_SLOTS} if $self->{+_MAX_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{max_slots} // undef; +} + +sub meta { + my $self = shift; + my ($key) = @_; + + $self->_scan unless $self->{+_SCANNED}; + my $meta = $self->{+_HEADERS}->{meta} or return (); + + return () unless $key && $meta->{$key}; + + return @{$meta->{$key}}; +} + +sub check_duration { + my $self = shift; + + return $self->{+_DURATION} if $self->{+_DURATION}; + + $self->_scan unless $self->{+_SCANNED}; + my $duration = $self->{+_HEADERS}->{duration}; + return $duration if $duration; + + my $timeout = $self->check_feature(timeout => 1); + + # 'long' for anything with no timeout + return 'long' unless $timeout; + + return 'medium'; +} + +sub check_category { + my $self = shift; + + return $self->{+_CATEGORY} if $self->{+_CATEGORY}; + + $self->_scan unless $self->{+_SCANNED}; + my $category = $self->{+_HEADERS}->{category}; + + return $category if $category; + + my $isolate = $self->check_feature(isolation => 0); + + # 'isolation' queue if isolation requested + return 'isolation' if $isolate; + + return 'general'; +} + +sub event_timeout { $_[0]->headers->{timeout}->{event} } +sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} } + +sub conflicts_list { + return $_[0]->headers->{conflicts} || []; # Assure conflicts is always an array ref. +} + +sub headers { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_HEADERS}; + return {%{$self->{+_HEADERS}}}; +} + +sub shbang { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_SHBANG}; + return {%{$self->{+_SHBANG}}}; +} + +sub switches { + my $self = shift; + + my $shbang = $self->shbang or return []; + my $switches = $shbang->{switches} or return []; + + return $switches; +} + +sub is_executable { + my $self = shift; + my ($file) = @_; + $file //= $self->{+FILE}; + return -x $file; +} + +sub scan { + my $self = shift; + $self->_scan(); + return; +} + +sub _scan { + my $self = shift; + + return if $self->{+_SCANNED}++; + return if $self->{+IS_BINARY}; + + my $fh = open_file($self->{+FILE}); + my $comment = $self->{+COMMENT} // '#'; + + my %headers; + for (my $ln = 1; my $line = <$fh>; $ln++) { + chomp($line); + next if $line =~ m/^\s*$/; + + if ($ln == 1 && $line =~ m/^#!/) { + my $shbang = $self->_parse_shbang($line); + if ($shbang) { + $self->{+_SHBANG} = $shbang; + + if ($shbang->{non_perl}) { + $self->{+NON_PERL} = 1; + + die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n" + unless $self->is_executable; + } + + next; + } + } + + # Uhg, breaking encapsulation between yath and the harness + if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) { + $headers{features}->{run} = 0; + next; + } + + next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/; # Ignore commented lines which aren't HARNESS-? + next if $line =~ m/^\s*(use|require|BEGIN|package)\b/; # Only supports single line BEGINs + last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/; + + my ($dir, $rest) = split /[-\s]+/, $1, 2; + $dir = lc($dir); + my @args; + if ($dir eq 'meta') { + @args = split /\s+/, $rest, 2; # Check for white space delimited + @args = split(/[-]+/, $rest, 2) if scalar @args == 1; # Check for dash delimited + $args[1] =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + } + elsif ($rest) { + $rest =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + @args = split /[-\s]+/, $rest; + } + + if ($dir eq 'no') { + my $feature = lc(join '_' => @args); + if ($feature eq 'retry') { + $headers{retry} = 0 + } else { + $headers{features}->{$feature} = 0; + } + } + elsif ($dir eq 'smoke') { + $headers{features}->{smoke} = 1; + } + elsif ($dir eq 'retry') { + $headers{retry} = 1 unless @args || defined $headers{retry}; + for my $arg (@args) { + if ($arg =~ m/^\d+$/) { + $headers{retry} = int $arg; + } + elsif ($arg =~ m/^iso/i) { + $headers{retry} //= 1; + $headers{retry_isolated} = 1; + } + else { + warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n"; + } + } + } + elsif ($dir eq 'yes' || $dir eq 'use') { + my $feature = lc(join '_' => @args); + $headers{features}->{$feature} = 1; + } + elsif ($dir eq 'stage') { + my ($name) = @args; + $headers{stage} = $name; + } + elsif ($dir eq 'meta') { + my ($key, $val) = @args; + $key = lc($key); + push @{$headers{meta}->{$key}} => $val; + } + elsif ($dir eq 'duration' || $dir eq 'dur') { + my ($name) = @args; + $name = lc($name); + $headers{duration} = $name; + } + elsif ($dir eq 'category' || $dir eq 'cat') { + my ($name) = @args; + $name = lc($name); + if ($name =~ m/^(long|medium|short)$/i) { + $headers{duration} = $name; + } + else { + $headers{category} = $name; + } + } + elsif ($dir eq 'conflicts') { + my @conflicts_array; + + foreach my $arg (@args) { + push @conflicts_array, lc($arg); + } + + # Allow multiple lines with # HARNESS-CONFLICTS FOO + $headers{conflicts} ||= []; + push @{$headers{conflicts}}, @conflicts_array; + + # Make sure no more than 1 conflict is ever present. + @{$headers{conflicts}} = uniq @{$headers{conflicts}}; + } + elsif ($dir eq 'timeout') { + my ($type, $num, $extra) = @args; + $type = lc($type); + $num = lc($num); + + ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit'; + + warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n" + unless $type =~ m/^(event|postexit)$/; + + $headers{timeout}->{$type} = $num; + } + elsif ($dir eq 'job' && $rest =~ m/slots\s+(\d+)(?:\s+(\d+))?$/i) { + $headers{min_slots} //= $1; + $headers{max_slots} //= $2 ? $2 : $1; + } + else { + warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n"; + } + } + + $self->{+_HEADERS} = \%headers; +} + +sub _parse_shbang { + my $self = shift; + my $line = shift; + + return {} if !defined $line; + + my %shbang; + + # NOTE: Test this, the dashes should be included with the switches + my $shbang_re = qr{ + ^ + \#!.*perl.*? # the perl path + (?: \s (-.+) )? # the switches, maybe + \s* + $ + }xi; + + if ($line =~ $shbang_re) { + my @switches; + @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; + $shbang{switches} = \@switches; + $shbang{line} = $line; + } + elsif ($line =~ m/^#!/ && $line !~ m/perl/i) { + $shbang{line} = $line; + $shbang{non_perl} = 1; + } + + return \%shbang; +} + +sub queue_item { + my $self = shift; + my ($job_name, $run_id, %inject) = @_; + + die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n" + unless $self->check_feature(run => 1); + + my $category = $self->check_category; + my $duration = $self->check_duration; + my $stage = $self->check_stage; + my $min_slots = $self->check_min_slots; + my $max_slots = $self->check_max_slots; + + my $smoke = $self->check_feature(smoke => 0); + my $fork = $self->check_feature(fork => 1); + my $preload = $self->check_feature(preload => 1); + my $timeout = $self->check_feature(timeout => 1); + my $stream = $self->check_feature(stream => 1); + my $io_events = $self->check_feature(io_events => 1); + + my $retry = $self->retry; + my $retry_isolated = $self->retry_isolated; + + my $binary = $self->{+IS_BINARY} ? 1 : 0; + my $non_perl = $self->{+NON_PERL} ? 1 : 0; + + my $et = $self->event_timeout; + my $pet = $self->post_exit_timeout; + + my $job_class = $self->job_class; + + my $input = $self->input; + my $test_args = $self->test_args; + + my $env_vars = $self->env_vars; + if ($env_vars) { + my $mix = delete $inject{env_vars}; + $env_vars = {%$mix, %$env_vars} if $mix; + } + + return { + binary => $binary, + category => $category, + conflicts => $self->conflicts_list, + duration => $duration, + file => $self->file, + rel_file => $self->relative, + job_id => gen_uuid(), + job_name => $job_name, + run_id => $run_id, + non_perl => $non_perl, + stage => $stage, + stamp => time, + switches => $self->switches, + use_fork => $fork, + use_preload => $preload, + use_stream => $stream, + use_timeout => $timeout, + smoke => $smoke, + io_events => $io_events, + rank => $self->rank, + + defined($input) ? (input => $input) : (), + defined($env_vars) ? (env_vars => $env_vars) : (), + defined($test_args) ? (test_args => $test_args) : (), + defined($job_class) ? (job_class => $job_class) : (), + defined($retry) ? (retry => $retry) : (), + defined($retry_isolated) ? (retry_isolated => $retry_isolated) : (), + defined($et) ? (event_timeout => $et) : (), + defined($pet) ? (post_exit_timeout => $self->post_exit_timeout) : (), + defined($min_slots) ? (min_slots => $min_slots) : (), + defined($max_slots) ? (max_slots => $max_slots) : (), + + @{$self->{+QUEUE_ARGS}}, + + %inject, + }; +} + +my %RANK = ( + smoke => 1, + immiscible => 10, + long => 20, + medium => 50, + short => 80, + isolation => 100, +); + +sub rank { + my $self = shift; + + return $RANK{smoke} if $self->check_feature('smoke'); + + my $rank = $RANK{$self->check_category}; + $rank ||= $RANK{$self->check_duration}; + $rank ||= 1; + + return $rank; +} + +sub TO_JSON { +{ %{$_[0]} } } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Task::TestFile - Abstraction of a test file and its meta-data. + +=head1 DESCRIPTION + +When Test2::Harness finds test files to run each one gets an instance of this +class to represent it. This class will scan test files to find important meta +data (binary vs script, inline harness directives, etc). The meta-data this +class can find helps yath decide when and how to run the test. + +If you write a custom L<Test2::Harness::Finder> or use some +L<Test2::Harness::Plugin> callbacks you may have to use, or even construct +instances of this class. + +=head1 SYNOPSIS + + use Test2::Harness::Task::TestFile; + + my $tf = Test2::Harness::Task::TestFile->new(file => "path/to/file.t"); + + # For an example 1, 1 works, but normally they are job_name and run_id. + my $meta_data = $tf->queue_item(1, 1); + + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $tf->file + +Set during object construction, and cannot be changed. + +=item $bool = $tf->is_binary + +Automatically set during construction, cannot be changed or set manually. + +=item $bool = $tf->non_perl + +Automatically set during construction, cannot be changed or set manually. + +=item $string = $tf->comment + +=item $tf->set_comment($string) + +Defaults to '#' can be set during construction, or changed if needed. + +This is used to tell yath what character(s) are used to denote a comment. This +is necessary for finding harness directives. In perl the '#' character is used, +and that is the default value. This is here to support non-perl tests. + +=item $class = $tf->job_class + +=item $tf->set_job_class($class) + +Default it undef (let the runner pick). You can change this if you want the +test to run with a custom job subclass. + +=item $arrayref = $tf->queue_args + +=item $tf->set_queue_args(\@ARGS) + +Key/Value pairs to append to the queue_item() data. + +=back + +=head1 METHODS + +=over 4 + +=item $cat = $tf->check_category() + +=item $tf->set_category($cat) + +This is how you find the category for a file. You can use C<set_category()> to +assign/override a category. + +=item $dur = $tf->check_duration() + +=item $tf->set_duration($dur) + +Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override +with C<set_duration()>. + +=item $stage = $tf->check_stage() + +=item $tf->set_stage($stage) + +Get the preload stage the test file thinks it should be run in. You can +override with C<set_stage()>. + +=item $bool = $tf->check_feature($name) + +This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or +C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES> +and C<USE> will result in a ture boolean. If no directive is found then +C<undef> will be returned. + +=item $arrayref = $tf->conflicts_list() + +Get a list of conflict markers. + +=item $seconds = $tf->event_timeout() + +If they test specifies an event timeout this will return it. + +=item %headers = $tf->headers() + +This returns the header data from the test file. + +=item $bool = $tf->is_executable() + +Check if the test file is executable or not. + +=item $data = $tf->meta($key) + +Get the meta-data for the specific key. + +=item $seconds = $tf->post_exit_timeout() + +If the test file has a custom post-exit timeout, this will return it. + +=item $hashref = $tf->queue_item($job_name, $run_id) + +This returns the data used to add the test file to the runner queue. + +=item $int = $tf->rank() + +Returns an integer value used to sort tests into an efficient run order. + +=item $path = $tf->relative() + +Relative path to the test file. + +=item $tf->scan() + +Scan the file and populate the header data. Return nothing, takes no arguments. +Automatically run by things that require the scan data. Results are cached. + +=item $tf->set_smoke($bool) + +Set smoke status. Smoke tests go to the front of the line when tests are +sorted. + +=item $hashref = $tf->shbang() + +Get data gathered from parsing the tests shbang line. + +=item $arrayref = $tf->switches() + +A list of switches passed to perl, usually from the shbang line. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util.pm b/lib2.0/Test2/Harness/Util.pm new file mode 100644 index 000000000..a23274737 --- /dev/null +++ b/lib2.0/Test2/Harness/Util.pm @@ -0,0 +1,635 @@ +package Test2::Harness::Util; +use strict; +use warnings; + +use Carp qw/confess/; +use Cwd qw/realpath/; +use List::Util qw/min/; +use Test2::Util qw/try_sig_mask do_rename/; +use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; +use File::Spec; + +our $VERSION = '2.000000'; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + find_libraries + clean_path + + parse_exit + mod2file + file2mod + fqmod + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + lock_file + unlock_file + + hub_truth + + apply_encoding + + process_includes + + chmod_tmp + + looks_like_uuid + is_same_file + + resize_pipe +}; + +sub resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh, $size) = @_; + + # 1mb if we can + $size //= 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub is_same_file { + my ($file1, $file2) = @_; + + return 0 unless defined $file1; + return 0 unless defined $file2; + + return 1 if "$file1" eq "$file2"; + return 1 if clean_path($file1) eq clean_path($file2); + + return 0 unless -e $file1; + return 0 unless -e $file2; + + my ($dev1, $inode1) = stat($file1); + my ($dev2, $inode2) = stat($file2); + + return 0 unless $dev1 == $dev2; + return 0 unless $inode1 == $inode2; + return 1; +} + +sub looks_like_uuid { + my ($in) = @_; + + return undef unless defined $in; + return undef unless length($in) == 36; + return undef unless $in =~ m/^[0-9A-F\-]+$/i; + return $in; +} + +sub chmod_tmp { + my $file = shift; + + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; + + chmod($mode, $file); +} + +sub process_includes { + my %params = @_; + + my @start = @{delete $params{list} // []}; + + my @list; + my %seen = ('.' => 1); + + if (my $ch_dir = delete $params{ch_dir}) { + for my $path (@start) { + # '.' is special. + $seen{'.'}++ and next if $path eq '.'; + + if (File::Spec->file_name_is_absolute($path)) { + push @list => $path; + } + else { + push @list => File::Spec->catdir($ch_dir, $path); + } + } + } + else { + @list = @start; + } + + push @list => @INC if delete $params{include_current}; + + @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + + @list = grep { !$seen{$_}++ } @list; + + # If we ask for dot, or saw it during our processing, add it to the end. + push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; + + confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + + return @list; +} + +sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); +} + +sub parse_exit { + my ($exit) = @_; + + my $sig = $exit & 127; + my $dmp = $exit & 128; + + return { + sig => $sig, + err => ($exit >> 8), + dmp => $dmp, + all => $exit, + }; +} + +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return "$prefix\::$input"; +} + +sub hub_truth { + my ($f) = @_; + + return $f->{hubs}->[0] if $f->{hubs} && @{$f->{hubs}}; + return $f->{trace} if $f->{trace}; + return {}; +} + +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} + +sub read_file { + my ($file, @args) = @_; + + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); + + return $out; +} + +sub write_file { + my ($file, @content) = @_; + + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); + + return @content; +}; + +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; + + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); + + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } + } + + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} + +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} + +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} + +sub write_file_atomic { + my ($file, @content) = @_; + + my $pend = "$file.pend"; + + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; + + die $err unless $ok; + + return @content; +} + +sub lock_file { + my ($file, $mode) = @_; + + my $fh; + if (ref $file) { + $fh = $file; + } + else { + open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; + } + + for (1 .. 21) { + flock($fh, LOCK_EX) and last; + die "Could not lock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not lock file: $!"; + } + + return $fh; +} + +sub unlock_file { + my ($fh) = @_; + for (1 .. 21) { + flock($fh, LOCK_UN) and last; + die "Could not unlock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not unlock file: $!"; + } + + return $fh; +} + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub mod2file { + my ($mod) = @_; + confess "No module name provided" unless $mod; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + return $file; +} + +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; +} + + +sub find_libraries { + my ($search, @paths) = @_; + my @parts = grep $_, split /::(\*)?/, $search; + + @paths = @INC unless @paths; + + @paths = map { File::Spec->canonpath($_) } @paths; + + my %prefixes = map {$_ => 1} @paths; + + my @found; + my @bases = ([map { [$_ => length($_)] } @paths]); + while (my $set = shift @bases) { + my $new_base = []; + my $part = shift @parts; + + for my $base (@$set) { + my ($dir, $prefix) = @$base; + if ($part ne '*') { + my $path = File::Spec->catdir($dir, $part); + if (@parts) { + push @$new_base => [$path, $prefix] if -d $path; + } + elsif (-f "$path.pm") { + push @found => ["$path.pm", $prefix]; + } + + next; + } + + opendir(my $dh, $dir) or next; + for my $item (readdir($dh)) { + next if $item =~ m/^\./; + my $path = File::Spec->catdir($dir, $item); + if (@parts) { + # Sometimes @INC dirs are nested in eachother. + next if $prefixes{$path}; + + push @$new_base => [$path, $prefix] if -d $path; + next; + } + + next unless -f $path && $path =~ m/\.pm$/; + push @found => [$path, $prefix]; + } + } + + push @bases => $new_base if @$new_base; + } + + my %out; + for my $found (@found) { + my ($path, $prefix) = @$found; + + my @file_parts = File::Spec->splitdir(substr($path, $prefix)); + shift @file_parts if $file_parts[0] eq ''; + + my $file = join '/' => @file_parts; + $file_parts[-1] = substr($file_parts[-1], 0, -3); + my $module = join '::' => @file_parts; + + $out{$module} //= $file; + } + + return \%out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util - General utiliy functions. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 MISC + +=over 4 + +=item apply_encoding($fh, $enc) + +Apply the specified encoding to the filehandle. + +B<Justification>: +L<PERLBUG 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923> +If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in +order to avoid the thread segfault. + +This is a reusable implementation of this: + + sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); + } + +=item $clean = clean_path($path) + +Take a file path and clean it up to a minimal absolute path if possible. Always +returns a path, but if it cannot be cleaned up it is unchanged. + +=item $hashref = find_libraries($search) + +=item $hashref = find_libraries($search, @paths) + +C<@INC> is used if no C<@paths> are provided. + +C<$search> should be a module name with C<*> wildcards replacing sections. + + find_libraries('Foo::*::Baz') + find_libraries('*::Bar::Baz') + find_libraries('Foo::Bar::*') + +These all look for modules matching the search, this is a good way to find +plugins, or similar patterns. + +The result is a hashref of C<< { $module => $path } >>. If a module exists in +more than 1 search path the first is used. + +=item $mod = fqmod($prefix, $mod) + +This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If +C<$mod> starts with the C<'+'> character the character will be removed and the +result returned without prepending C<$prefix>. + +=item hub_truth + +This is an internal implementation detail, do not use it. + +=item $hashref = parse_exit($?) + +This parses the exit value as typically stored in C<$?>. + +Resulting hash: + + { + sig => ($? & 127), # Signal value if the exit was caused by a signal + err => ($? >> 8), # Actual exit code, if any. + dmp => ($? & 128), # Was there a core dump? + all => $?, # Original exit value, unchanged + } + + +=item @list = process_includes(%PARAMS) + +This method will build up a list of include dirs fit for C<@INC>. The returned +list should contain only unique values, in proper order. + +Params: + +=over 4 + +=item list => \@START + +Paths to start the new list. + +Optional. + +=item ch_dir => $path + +Prefix to prepend to all paths in the C<list> param. No effect without an +initial list. + +=item include_current => $bool + +This will add all paths from C<@INC> to the output, after the initial list. +Note that '.', if in C<@INC> will be moved to the end of the final output. + +=item clean => $bool + +If included all paths except C<'.'> will be cleaned using C<clean_path()>. + +=item include_dot => $bool + +If true C<'.'> will be appended to the end of the output. + +B<Note> even if this is set to false C<'.'> may still be included if it was in +the initial list, or if it was in C<@INC> and C<@INC> was included using the +C<include_current> parameter. + +=back + +=back + +=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION + +These convert between module names like C<Foo::Bar> and filenames like +C<Foo/Bar.pm>. + +=over 4 + +=item $file = mod2file($mod) + +=item $mod = file2mod($file) + +=back + +=head2 FOR READING/WRITING FILES + +=over 4 + +=item $fh = open_file($path, $mode) + +=item $fh = open_file($path) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = read_file($file) + +This will open the file at C<$path> and return all its contents. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $fh = maybe_open_file($path) + +=item $fh = maybe_open_file($path, $mode) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +C<undef> is returned if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = maybe_read_file($path) + +This will open the file at C<$path> and return all its contents. + +This will return C<undef> if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item @content = write_file($path, @content) + +Write content to the specified file. This will open the file with mode +C<< '>' >>, write the content, then close the file. + +An exception will be thrown if any part fails. + +=item @content = write_file_atomic($path, @content) + +This will open a temporary file, write the content, close the file, then rename +the file to the desired C<$path>. This is essentially an atomic write in that +C<$file> will not exist until all content is written, preventing other +processes from doing a partial read while C<@content> is being written. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/File.pm b/lib2.0/Test2/Harness/Util/File.pm new file mode 100644 index 000000000..93168fe6f --- /dev/null +++ b/lib2.0/Test2/Harness/Util/File.pm @@ -0,0 +1,256 @@ +package Test2::Harness::Util::File; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use IO::Handle; + +use Test2::Harness::Util(); + +use Carp qw/croak confess/; +use Fcntl qw/SEEK_SET SEEK_CUR/; + +use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos <skip_bad_decode }; + +sub exists { -e $_[0]->{+NAME} } + +sub decode { shift; $_[0] } +sub encode { shift; $_[0] } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+_INIT_FH} = delete $self->{fh}; +} + +sub open_file { + my $self = shift; + return Test2::Harness::Util::open_file($self->{+NAME}, @_) +} + +sub maybe_read { + my $self = shift; + return undef unless -e $self->{+NAME}; + return $self->read; +} + +sub read { + my $self = shift; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +sub rewrite { + my $self = shift; + return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); +} + +sub write { + my $self = shift; + return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); +} + +sub reset { + my $self = shift; + delete $self->{+_FH}; + delete $self->{+DONE}; + delete $self->{+LINE_POS}; + return; +} + +sub fh { + my $self = shift; + return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; + + # Remove any other PID handles + $self->{+_FH} = {}; + + if (my $fh = $self->{+_INIT_FH}) { + $self->{+_FH}->{$$} = $fh; + } + else { + $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; + } + + $self->{+_FH}->{$$}->blocking(0); + return $self->{+_FH}->{$$}; +} + +sub read_line { + my $self = shift; + my %params = @_; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; + seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" + if eof($fh) || tell($fh) != $pos; + + my $line = <$fh>; + + # No line, nothing to do + return unless defined $line && length($line); + + # Partial line, hold off unless done + return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; + + my $new_pos = tell($fh); + die "Failed to 'tell': $!" if $new_pos == -1; + + my $err = 0; + local $@; + unless (eval { $line = $self->decode($line); 1 }) { + $err = $@ // 'error'; + confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; + warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; + $line = undef; + } + + $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; + return $line unless wantarray; + return ($pos, $new_pos, $line, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File - Utility class for manipulating a file. + +=head1 DESCRIPTION + +This is a utility class for file operations. This also serves as a base class +for several file helpers. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File; + + my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); + + $f->write($content); + + my $fh = $f->open_file('<'); + + # Read, throw exception if it cannot read + my $content = $f->read(); + + # Try to read, but do not throw an exception if it cannot be read. + my $content_or_undef = $f->maybe_read(); + + my $line1 = $f->read_line(); + my $line2 = $f->read_line(); + ... + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $f->name; + +Get the filename. Must also be provided during construction. + +=item $bool = $f->done; + +True if read_line() has read every line. + +=back + +=head1 METHODS + +=over 4 + +=item $decoded = $f->decode($encoded) + +This is a no-op, it returns the argument unchanged. This is called by C<read> +and C<read_line>. Subclasses can override this if the file contains encoded +data. + +=item $encoded = $f->encode($decoded) + +This is a no-op, it returns the argument unchanged. This is called by C<write>. +Subclasses can override this if the file contains encoded data. + +=item $bool = $f->exists() + +Check if the file exists + +=item $content = $f->maybe_read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will return undef. + +=item $fh = $f->open_file() + +=item $fh = $f->open_file($mode) + +Open a handle to the file. If no $mode is provided C<< '<' >> is used. + +=item $content = $f->read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will throw an exception. + +=item $line = $f->read_line() + +Read a single line from the file, subsequent calls will read the next line and +so on until the end of the file is reached. Reset with the C<reset()> method. + +=item $f->reset() + +Reset the internal line iterator used by C<read_line()>. + +=item $f->write($content) + +This is an atomic-write. First $content will be written to a temporary file +using C<< '>' >> mode. Then the temporary file will be renamed to the desired +file name. Under the hood this uses C<write_file_atomic()> from +L<Test2::Harness::Util>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/File/JSON.pm b/lib2.0/Test2/Harness/Util/File/JSON.pm new file mode 100644 index 000000000..672bb9311 --- /dev/null +++ b/lib2.0/Test2/Harness/Util/File/JSON.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSON; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak confess/; +use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/pretty/; + +sub decode { shift; decode_json(@_) } +sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } + +sub reset { croak "line reading is disabled for json files" } +sub read_line { croak "line reading is disabled for json files" } + +sub maybe_read { + my $self = shift; + + return undef unless -e $self->{+NAME}; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + return undef unless defined($out) && length($out); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSON - Utility class for a JSON file. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> which automatically handles +encoding/decoding JSON data. + +=head1 SYNOPSIS + + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); + + $hash = $file->read; + # or + $$file->write({...}); + +=head1 SEE ALSO + +See the base class L<Test2::Harness::Util::File> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/File/JSONL.pm b/lib2.0/Test2/Harness/Util/File/JSONL.pm new file mode 100644 index 000000000..ce64c51b3 --- /dev/null +++ b/lib2.0/Test2/Harness/Util/File/JSONL.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSONL; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::Util::File::Stream'; +use Test2::Harness::Util::HashBase; + +sub decode { shift; decode_json($_[0]) } +sub encode { shift; encode_json(@_) . "\n" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> which automatically handles +encoding/decoding JSONL data. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + while (1) { + my @items = $jsonl->poll(max => 1000) or last; + for my $item (@items) { + ... handle $item ... + } + } + +or + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + $jsonl->write({my => 'item', ... }); + ... + +=head1 SEE ALSO + +See the base classes L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/File/Stream.pm b/lib2.0/Test2/Harness/Util/File/Stream.pm new file mode 100644 index 000000000..0e277b15a --- /dev/null +++ b/lib2.0/Test2/Harness/Util/File/Stream.pm @@ -0,0 +1,226 @@ +package Test2::Harness::Util::File::Stream; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/lock_file unlock_file/; +use Fcntl qw/SEEK_SET/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/use_write_lock -tail +_wfh +_wpid/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + my $tail = $self->{+TAIL} // return; + + return unless $self->exists; + + my @lines = $self->poll_with_index; + if (!@lines) { + $self->seek(0); + } + elsif (!$tail) { + $self->seek($lines[-1]->[1]); + } + elsif (@lines < $self->{+TAIL}) { + $self->seek(0); + } + else { + $self->seek($lines[0 - $tail]->[0]); + } +} + +sub poll_with_index { + my $self = shift; + my %params = @_; + + my $max = delete $params{max} || 0; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + return unless $pos < -s $self->name; + + my @out; + while (!$max || @out < $max) { + my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); + last unless defined($line) || defined($spos) || defined($epos) || $err; + + $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; + push @out => [$spos, $epos, $line] unless $err; + $pos = $epos; + } + + return @out; +} + +sub read { + my $self = shift; + + return $self->poll(from => 0); +} + +sub poll { + my $self = shift; + my @lines = $self->poll_with_index(@_); + return map { $_->[-1] } @lines; +} + +sub write { + my $self = shift; + + my $name = $self->{+NAME}; + + my $fh; + if ($self->{+USE_WRITE_LOCK}) { + $fh = lock_file($self->name, '>>'); + $fh->autoflush(1); + } + else { + unless ($self->{+_WPID} && $self->{+_WPID} == $$) { + delete $self->{+_WFH}; + $self->{+_WPID} = $$; + } + + if ($fh = $self->{+_WFH}) { + seek($fh, 2, 0); + } + else { + $fh = $self->{+_WFH} = Test2::Harness::Util::open_file($self->name, '>>'); + $fh->autoflush(1); + } + } + + print {$fh} $self->encode($_) for @_; + + if ($self->{+USE_WRITE_LOCK}) { + unlock_file($fh); + close($fh) or die "Could not close file '$name': $!"; + } + + return @_; +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + my $fh = $self->fh; + my $name = $self->{+NAME}; + + seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; + $self->{+LINE_POS} = $pos; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Stream - Utility class for manipulating a file that +serves as an output stream. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::File> that streams the contents of a file, even +if the file is still being written. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Stream; + + my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); + + # Read some lines + my @lines = $stream->poll; + + ... + + # Read more lines, if any. + push @lines => $stream->poll; + +=head1 ATTRIBUTES + +See L<Test2::Harness::File> for additional attributes. + +These can be passed in as construction arguments if desired. + +=over 4 + +=item $bool = $stream->use_write_lock + +=item $stream->use_write_lock($bool) + +Lock the file for every C<write()> operation. + +=item $bool = $stream->tail + +Start near the end of the file and only poll for updates appended to it. + +=back + +=head1 METHODS + +See L<Test2::Harness::File> for additional methods. + +=over 4 + +=item @lines = $stream->read() + +Read all lines from the beginning. Every time it is called it returns ALL lines. + +=item @lines = $stream->poll() + +=item @lines = $stream->poll(max => $int) + +Poll for lines. This is an iterator, it should not return the same line more +than once, you can call it multiple times to get any additional lines that have +been added since the last poll. + +=item $stream->write(@content) + +Append @content to the file. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/HashBase.pm b/lib2.0/Test2/Harness/Util/HashBase.pm new file mode 100644 index 000000000..f5d2a6b59 --- /dev/null +++ b/lib2.0/Test2/Harness/Util/HashBase.pm @@ -0,0 +1,496 @@ +package Test2::Harness::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '0.010'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.010'; + *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub spec { \%SPEC } + +sub import { + my $class = shift; + my $into = caller; + $class->do_import($into, @_); +} + +sub do_import { + my $class = shift; + my $into = shift; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; + $Test2::Harness::Util::HashBase::VERSION{$into} = $ver if !$Test2::Harness::Util::HashBase::VERSION{$into} || $Test2::Harness::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => $class->can('_new'))), + (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ($class->args_to_subs($attr_list, $attr_subs, \@_)), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub args_to_subs { + my $class = shift; + my ($attr_list, $attr_subs, $args) = @_; + + my $use_gen = $class->can('gen_accessor') ; + + my %out; + + while (@$args) { + my $x = shift @$args; + my $p = substr($x, 0, 1); + + my $spec = $class->spec->{$p} || {reader => 1, writer => 1}; + substr($x, 0, 1) = '' if $spec->{strip}; + + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + $out{$sub} = $attr_subs->{$sub}; + + my $copy = "$attr"; + $out{$attr} = $use_gen ? $class->gen_accessor(reader => $copy, $spec, $args) : sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(writer => $copy, $spec, $args) : sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(read_only => $copy, $spec, $args) : sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = $use_gen ? $class->gen_accessor(dep_writer => $copy, $spec, $args) : sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + if ($spec->{custom}) { + my %add = $class->gen_accessor(custom => $copy, $spec, $args); + $out{$_} = $add{$_} for keys %add; + } + } + + return %out; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Harness::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Harness::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Harness::Util::HashBase>. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Harness::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B<Note:> Test2::Harness::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Harness::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'s key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Harness::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Harness::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Harness::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Harness::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Harness::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Harness::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Harness::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Harness::Util::HashBase class. + +=over 4 + +=item @list = Test2::Harness::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Harness::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/IPC.pm b/lib2.0/Test2/Harness/Util/IPC.pm new file mode 100644 index 000000000..71f9cc2e8 --- /dev/null +++ b/lib2.0/Test2/Harness/Util/IPC.pm @@ -0,0 +1,70 @@ +package Test2::Harness::Util::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Cwd qw/getcwd/; +use Errno qw/ESRCH/; +use Config qw/%Config/; +use Test2::Util qw/CAN_REALLY_FORK/; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + USE_P_GROUPS + swap_io + pid_is_running +}; + +BEGIN { + if ($Config{'d_setpgrp'}) { + *USE_P_GROUPS = sub() { 1 }; + } + else { + *USE_P_GROUPS = sub() { 0 }; + } +} + +sub pid_is_running { + my ($pid) = @_; + + local $!; + return 1 if kill(0, $pid) || $! != ESRCH; + return 0; +} + +sub swap_io { + my ($fh, $to, $die, $mode) = @_; + + $die ||= sub { + my @caller = caller; + my @caller2 = caller(1); + die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); + }; + + my $orig_fd; + if (ref($fh) eq 'ARRAY') { + ($orig_fd, $fh) = @$fh; + } + else { + $orig_fd = fileno($fh); + } + + $die->("Could not get original fd ($fh)") unless defined $orig_fd; + + if (ref($to)) { + $mode //= $orig_fd ? '>&' : '<&'; + open($fh, $mode, $to) or $die->("Could not redirect output: $!"); + } + else { + $mode //= $orig_fd ? '>' : '<'; + open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); + } + + return if fileno($fh) == $orig_fd; + + $die->("New handle does not have the desired fd!"); +} + +1; diff --git a/lib2.0/Test2/Harness/Util/JSON.pm b/lib2.0/Test2/Harness/Util/JSON.pm new file mode 100644 index 000000000..820e0eebe --- /dev/null +++ b/lib2.0/Test2/Harness/Util/JSON.pm @@ -0,0 +1,263 @@ +package Test2::Harness::Util::JSON; +use strict; +use warnings; + +use Carp qw/croak confess/; + +our $VERSION = '1.000152'; + +BEGIN { + local $@ = undef; + my $ok = eval { + require JSON::MaybeXS; + JSON::MaybeXS->import('JSON'); + 1; + + if (JSON() eq 'JSON::PP') { + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + elsif (JSON() eq 'JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 1 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + elsif (JSON() eq 'Cpanel::JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 1 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + }; + + unless ($ok) { + require JSON::PP; + *JSON = sub() { 'JSON::PP' }; + + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + +} + +our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; +our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); +my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); + +sub encode_json { eval { $json->encode(@_) } // confess($@)} +sub encode_canon_json { eval { $canon->encode(@_) } // confess($@)} +sub encode_pretty_json { eval { $pretty->encode(@_) } // confess($@)} + +sub decode_json { + my ($input) = @_; + my $data; + + local $@; + my $error; + + # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally + # testing bytes behavior we need to accept the bytes from the JSON file instead. + my $ok = eval { $data = $json->decode($input); 1 } || do { + $error = $@; + eval { $data = $json_non_utf8->decode($input); 1 }; + }; + $error ||= $@; + return $data if $ok; + my $mess = Carp::longmess("JSON decode error: $error"); + die "$mess\n=======\n$input\n=======\n"; +} + +sub stream_json_l { + my ($path, $handler, %params) = @_; + + croak "No path provided" unless $path; + + return stream_json_l_file($path, $handler) if -f $path; + return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; + + croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; +} + +sub stream_json_l_file { + my ($path, $handler) = @_; + + croak "Invalid file '$path'" unless -f $path; + + croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." + unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; + + if ($1 eq 'json') { + require Test2::Harness::Util::File::JSON; + my $json = Test2::Harness::Util::File::JSON->new(name => $path); + $handler->($json->read); + } + else { + require Test2::Harness::Util::File::JSONL; + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); + while (my ($item) = $jsonl->poll(max => 1)) { + $handler->($item); + } + } + + return 1; +} + +sub stream_json_l_url { + my ($path, $handler, %params) = @_; + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args} // []; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + my $buffer = ''; + my $iterate = sub { + my ($res) = @_; + + my @parts = split /(\n)/, $buffer; + + while (@parts > 1) { + my $line = shift @parts; + my $nl = shift @parts; + my $data; + unless (eval { $data = decode_json($line); 1 }) { + warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; + next; + } + + $handler->($data, $res); + } + + $buffer = shift @parts // ''; + }; + + my $res = $ht->$meth( + $path, + { + @$args, + data_callback => sub { + my ($chunk, $res) = @_; + $buffer .= $chunk; + $iterate->($res); + }, + } + ); + + if (length($buffer)) { + $buffer .= "\n" unless $buffer =~ m/\n$/; + $iterate->($res); + } + + return $res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best +JSON implementation. + +=head1 DESCRIPTION + +This package provides functions for encoding/decoding json, and uses the best +json tools available. + +=head1 SYNOPSIS + + use Test2::Harness::Util::JSON qw/encode_json decode_json/; + + my $data = { foo => 1 }; + my $json = encode_json($data); + my $copy = decode_json($json); + +=head1 EXPORTS + +=over 4 + +=item $package = JSON() + +This returns the JSON package being used by yath. + +=item $bool = JSON_IS_PP() + +True if yath is using L<JSON::PP>. + +=item $bool = JSON_IS_XS() + +True if yath is using L<JSON::XS>. + +=item $bool = JSON_IS_CPANEL() + +True if yath is using L<Cpanel::JSON::XS>. + +=item $bool = JSON_IS_CPANEL_OR_XS() + +True if either L<JSON::XS> or L<Cpanel::JSON::XS> are being used. + +=item $string = encode_json($data) + +Encode data into json. String will be 1-line. + +=item $data = decode_json($string) + +Decode json data from the string. + +=item $string = encode_pretty_json($data) + +Encode into human-friendly json. + +=item $string = encode_canon_json($data) + +Encode into canon-json. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/Term.pm b/lib2.0/Test2/Harness/Util/Term.pm new file mode 100644 index 000000000..da0b6a306 --- /dev/null +++ b/lib2.0/Test2/Harness/Util/Term.pm @@ -0,0 +1,104 @@ +package Test2::Harness::Util::Term; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; + +use Importer Importer => 'import'; +our @EXPORT_OK = qw/USE_ANSI_COLOR/; + +{ + my $use = 0; + local ($@, $!); + + if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { + if (IS_WIN32) { + if (eval { require Win32::Console::ANSI }) { + Win32::Console::ANSI->import(); + $use = 1; + } + } + else { + $use = 1; + } + } + + if ($use) { + *USE_ANSI_COLOR = sub() { 1 }; + } + else { + *USE_ANSI_COLOR = sub() { 0 }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Term - Terminal utilities for Test2::Harness + +=head1 DESCRIPTION + +This module provides information about the terminal in which the harness is +running. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + + if (USE_ANSI_COLOR) { + ... + } + else { + ... + } + +=head1 EXPORTS + +=over 4 + +=item $bool = USE_ANSI_COLOR() + +True if L<Term::ANSIColor> is available and usable. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/lib2.0/Test2/Harness/Util/UUID.pm b/lib2.0/Test2/Harness/Util/UUID.pm new file mode 100644 index 000000000..459bea92e --- /dev/null +++ b/lib2.0/Test2/Harness/Util/UUID.pm @@ -0,0 +1,85 @@ +package Test2::Harness::Util::UUID; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Data::UUID; +use Importer 'Importer' => 'import'; + +our @EXPORT = qw/gen_uuid/; +our @EXPORT_OK = qw/UG gen_uuid/; + +my ($UG, $UG_PID); +sub UG { + return $UG if $UG && $UG_PID && $UG_PID == $$; + + $UG_PID = $$; + return $UG = Data::UUID->new; +} + +sub gen_uuid { UG()->create_str() } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::UUID - Utils for generating UUIDs. + +=head1 DESCRIPTION + +This module provides a consistent UUID source for all of Test2::Harness. + +=head1 SYNOPSIS + + use Test2::Harness::Util::UUID qw/gen_uuid/; + + my $uuid = gen_uuid; + +=head1 EXPORTS + +=over 4 + +=item $uuid = gen_uuid() + +Generate a UUID. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath.pm b/libold2/App/Yath.pm new file mode 100644 index 000000000..2d38ff012 --- /dev/null +++ b/libold2/App/Yath.pm @@ -0,0 +1,879 @@ +package App::Yath; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw{ + -config + -settings + + -_options -options_loaded + -_argv -argv_processed <_orig_argv + + -_command_class -_command_name -_early_command +}; + +use Time::HiRes qw/time/; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/find_libraries clean_path/; +use App::Yath::Options(); +use Scalar::Util qw/blessed/; + +my $APP_PATH = __FILE__; +$APP_PATH =~ s{App\S+Yath\.pm$}{}g; +$APP_PATH = clean_path($APP_PATH); +sub app_path { $APP_PATH } + +sub init { + my $self = shift; + + my $old = select STDOUT; + $| = 1; + select STDERR; + $| = 1; + select $old; + + my @caller = caller(1); + + $self->{+SETTINGS} //= Test2::Harness::Settings->new; + + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('script')} //= clean_path($caller[1]); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('start')} //= time(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('no_scan_plugins')} //= 0; + + $self->{+_ARGV} //= delete($self->{argv}) // []; + $self->{+_ORIG_ARGV} = [@{$self->{+_ARGV}}]; + $self->{+CONFIG} //= {}; +} + +sub generate_run_sub { + my $self = shift; + my ($symbol) = @_; + + my $cmd_class; + my ($options, $argv); + + if (my $cmd = $self->_command_from_argv(no_default => 1, valid_only => 1)) { + $cmd_class = $self->load_command($cmd); + + $self->{+_COMMAND_NAME} = $cmd; + $self->{+_COMMAND_CLASS} = $cmd_class; + + if ($cmd_class->only_cmd_opts) { + $self->{+_EARLY_COMMAND} = 1; + my $settings = $self->{+SETTINGS}; + + $options = App::Yath::Options->new(settings => $settings); + $options->set_command_class($cmd_class); + $options->set_args($self->{+_ARGV}); + + $argv = $self->{+_ARGV}; + $cmd_class->munge_opts($options, $argv, $settings); + } + } + + $options //= $self->load_options(); + + $cmd_class //= $self->command_class(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('command')} //= $cmd_class; + + $argv = $self->process_argv(); + + return $cmd_class->generate_run_sub($symbol, $argv, $self->{+SETTINGS}, $self->{+_ORIG_ARGV}) if $cmd_class->can('generate_run_sub'); + + my $cmd = $cmd_class->new(settings => $options->settings, args => $argv, orig_args => $self->{+_ORIG_ARGV}); + + $options->process_option_post_actions($cmd); + + my $run = sub { $self->run_command($cmd) }; + + { + no strict 'refs'; + *{$symbol} = $run; + } + + return; +} + +sub run_command { + my $self = shift; + my ($cmd) = @_; + + my $exit = $cmd->run; + + die "Command '" . $cmd->name() . "' did not return an exit value.\n" + unless defined $exit; + + return $exit; +} + +sub load_options { + my $self = shift; + + my $settings = $self->{+SETTINGS} = $self->{+SETTINGS}; + + my $options = $self->{+_OPTIONS} //= App::Yath::Options->new(settings => $settings); + + return $options if $self->{+OPTIONS_LOADED}++; + + $options->include_from( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ); + + return $options if $self->{+SETTINGS}->harness->no_scan_plugins; + + my $option_libs = { + %{find_libraries('App::Yath::Plugin::*')}, + %{find_libraries('Test2::Harness::Runner::Resource::*')}, + }; + for my $lib (sort keys %$option_libs) { + my $ok = eval { require $option_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load module '$option_libs->{$lib}': $@"; + next; + } + + next unless $lib->can('options'); + my $add = $lib->options; + next unless $add; + + unless (blessed($add) && $add->isa('App::Yath::Options')) { + warn "Module '$option_libs->{$lib}' is outdated, not loading options.\n" + unless $ENV{'YATH_SELF_TEST'}; + next; + } + + $options->include_from($lib); + } + + return $options; +} + +sub process_argv { + my $self = shift; + + return $self->{+_ARGV} if $self->{+ARGV_PROCESSED}++; + + my $options = $self->load_options(); + my $settings = $self->settings; + + my $config_pre_args = $self->{+CONFIG}->{'~'}; + $options->grab_pre_command_opts(args => $config_pre_args, stop_at_non_opt => 0, passthrough => 0, die_at_non_opt => 1) + if $config_pre_args; + + $options->set_args($self->{+_ARGV}); + $options->grab_pre_command_opts(); + + $options->process_pre_command_opts(); + + my $cmd_name = $self->_command_from_argv(); + my $cmd_class = $self->load_command($cmd_name); + die "Command '$cmd_name' needs to be specified earlier in the command line arguments to yath.\n" if $cmd_class->only_cmd_opts && !$self->{+_EARLY_COMMAND}; + $options->set_command_class($cmd_class); + $self->{+_COMMAND_CLASS} = $cmd_class; + + $options->grab_pre_command_opts(stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0); + + my $config_cmd_args = $self->{+CONFIG}->{$cmd_name}; + + $options->grab_pre_command_opts(args => $config_cmd_args, stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0) + if $config_cmd_args; + + $options->process_pre_command_opts(); + + $options->grab_command_opts(args => $config_cmd_args, die_at_non_opt => 1, stop_at_non_opt => 0, passthrough => 0) + if $config_cmd_args; + + $options->grab_command_opts(); + $options->process_command_opts(); + + $options->clear_env(); + + $self->clear_env(); + + my %seen = map {((ref($_) || $_) => 1)} @{$settings->harness->plugins}; + for my $plugin (@{$options->used_plugins}) { + next if $seen{$plugin}++; + push @{$settings->harness->plugins} => $plugin->can('new') ? $plugin->new() : $plugin; + } + + return $self->{+_ARGV}; +} + +sub clear_env { + delete $ENV{HARNESS_IS_VERBOSE}; + delete $ENV{T2_FORMATTER}; + delete $ENV{T2_HARNESS_FORKED}; + delete $ENV{T2_HARNESS_IS_VERBOSE}; + delete $ENV{T2_HARNESS_JOB_IS_TRY}; + delete $ENV{T2_HARNESS_JOB_NAME}; + delete $ENV{T2_HARNESS_PRELOAD}; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_FILE}; + delete $ENV{T2_STREAM_JOB_ID}; + delete $ENV{TEST2_JOB_DIR}; + delete $ENV{TEST2_RUN_DIR}; + + # If Test2::API is already loaded then we need to keep these. + delete $ENV{TEST2_ACTIVE} unless $INC{'Test2/API.pm'}; + delete $ENV{TEST_ACTIVE} unless $INC{'Test2/API.pm'}; +} + +sub command_class { + my $self = shift; + + $self->process_argv() unless $self->{+_COMMAND_CLASS}; + + return $self->{+_COMMAND_CLASS}; +} + +sub _command_from_argv { + my $self = shift; + my %params = @_; + + return $self->{+_COMMAND_NAME} if $self->{+_COMMAND_NAME}; + + my $argv = $self->{+_ARGV}; + + for (my $idx = 0; $idx < @$argv; $idx++) { + my $arg = $argv->[$idx]; + + if ($arg =~ m/^-*h(elp)?$/i) { + splice(@$argv, $idx, 1); + return 'help'; + } + + if ($arg eq 'do') { + splice(@$argv, $idx, 1); + last; + } + + last if $arg eq '::'; + next if $arg =~ /^-/; + + if ($arg =~ m/\.jsonl(\.bz2|\.gz)?$/) { + warn "\n** First argument is a log file, defaulting to the 'replay' command **\n\n"; + return 'replay'; + } + + return splice(@$argv, $idx, 1) if $self->load_command($arg, check_only => 1); + return if $params{valid_only}; + + my $is_path = 0; + $is_path ||= -f $arg; + $is_path ||= -d $arg; + + # Assume it is a command, but an invalid one. + return splice(@$argv, $idx, 1) unless $is_path; + } + + return if $params{no_default}; + + if (my $pfile = find_pfile($self->settings, no_checks => 1)) { + warn "\n** Persistent runner detected, defaulting to the 'run' command **\n\n"; + return 'run'; + } + + warn "\n** Defaulting to the 'test' command **\n\n"; + return 'test'; +} + +sub load_command { + my $self = shift; + my ($cmd_name, %params) = @_; + + my $cmd_class = "App::Yath::Command::$cmd_name"; + my $cmd_file = "App/Yath/Command/$cmd_name.pm"; + + return $cmd_class if eval { require $cmd_file; 1 }; + my $error = $@ || 'unknown error'; + + my $not_found = $error =~ m{Can't locate \Q$cmd_file\E in \@INC}; + + return undef if $params{check_only} && $not_found; + + die "yath command '$cmd_name' not found. (did you forget to install $cmd_class?)\n" + if $not_found; + + die $error; +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath - Yet Another Test Harness (Test2-Harness) Command Line Interface +(CLI) + +=head1 DESCRIPTION + +This is the primary documentation for C<yath>, L<App::Yath>, L<Test2::Harness>. + +The canonical source of up-to-date command options are the help output when +using C<$ yath help> and C<$ yath help COMMAND>. + +This document is mainly an overview of C<yath> usage and common recipes. + +L<App::Yath> is an alternative to L<App::Prove>, and L<Test2::Harness> is an alternative to L<Test::Harness>. It is not designed to +replace L<Test::Harness>/prove. L<Test2::Harness> is designed to take full +advantage of the rich data L<Test2> can provide. L<Test2::Harness> is also able to +use non-core modules and provide more functionality than prove can achieve with +its restrictions. + +=head1 PLATFORM SUPPORT + +L<Test2::Harness>/L<App::Yath> is is focused on unix-like platforms. Most +development happens on linux, but bsd, macos, etc should work fine as well. + +Patches are welcome for any/all platforms, but the primary author (Chad +'Exodist' Granum) does not directly develop against non-unix platforms. + +=head2 WINDOWS + +Currently windows is not supported, and it is known that the package will not +install on windows. Patches are be welcome, and it would be great if someone +wanted to take on the windows-support role, but it is not a primary goal for +the project. + +=head1 OVERVIEW + +To use L<Test2::Harness>, you use the C<yath> command. Yath will find the tests +(or use the ones you specify) and run them. As it runs, it will output +diagnostic information such as failures. At the end, yath will print a summary +of the test run. + +C<yath> can be thought of as a more powerful alternative to C<prove> +(L<Test::Harness>) + +=head1 RECIPES + +These are common recipes for using C<yath>. + +=head2 RUN PROJECT TESTS + + $ yath + +Simply running yath with no arguments means "Run all tests for the current +project". Yath will look for tests in C<./t>, C<./t2>, and C<./test.pl> and +run any which are found. + +Normally this implies the C<test> command but will instead imply the C<run> +command if a persistent test runner is detected. + +=head2 PRELOAD MODULES + +Yath has the ability to preload modules. Yath normally forks to start new +tests, so preloading can reduce the time spent loading modules over and over in +each test. + +Note that some tests may depend on certain modules not being loaded. In these +cases you can add the C<# HARNESS-NO-PRELOAD> directive to the top of the test +files that cannot use preload. + +=head3 SIMPLE PRELOAD + +Any module can be preloaded: + + $ yath -PMoose + +You can preload as many modules as you want: + + $ yath -PList::Util -PScalar::Util + +=head3 COMPLEX PRELOAD + +If your preload is a subclass of L<Test2::Harness::Runner::Preload> then more +complex preload behavior is possible. See those docs for more info. + +=head2 LOGGING + +=head3 RECORDING A LOG + +You can turn on logging with a flag. The filename of the log will be printed at +the end. + + $ yath -L + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl + +The event log can be quite large. It can be compressed with bzip2. + + $ yath -B + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +gzip compression is also supported. + + $ yath -G + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.gz + +C<-B> and C<-G> both imply C<-L>. + +=head3 REPLAYING FROM A LOG + +You can replay a test run from a log file: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +This will be significantly faster than the initial run as no tests are actually +being executed. All events are simply read from the log, and processed by the +harness. + +You can change display options and limit rendering/processing to specific test +jobs from the run: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 -v [TEST UUID(S)] + +Note: This is done using the C<$ yath replay ...> command. The C<replay> +command is implied if the first argument is a log file. + +=head2 PER-TEST TIMING DATA + +The C<-T> option will cause each test file to report how long it took to run. + + $ yath -T + + ( PASSED ) job 1 t/yath_script.t + ( TIME ) job 1 Startup: 0.07692s | Events: 0.01170s | Cleanup: 0.00190s | Total: 0.09052s + +=head2 PERSISTENT RUNNER + +yath supports starting a yath session that waits for tests to run. This is very +useful when combined with preload. + +=head3 STARTING + +This starts the server. Many options available to the 'test' command will work +here but not all. See C<$ yath help start> for more info. + + $ yath start + +=head3 RUNNING + +This will run tests using the persistent runner. By default, it will search for +tests just like the 'test' command. Many options available to the C<test> +command will work for this as well. See C<$ yath help run> for more details. + + $ yath run + +=head3 STOPPING + +Stopping a persistent runner is easy. + + $ yath stop + +=head3 INFORMATIONAL + +The C<which> command will tell you which persistent runner will be used. Yath +searches for the persistent runner in the current directory, then searches in +parent directories until it either hits the root directory, or finds the +persistent runner tracking file. + + $ yath which + +The C<watch> command will tail the runner's log files. + + $ yath watch + +=head3 PRELOAD + PERSISTENT RUNNER + +You can use preloads with the C<yath start> command. In this case, yath will +track all the modules pulled in during preload. If any of them change, the +server will reload itself to bring in the changes. Further, modified modules +will be blacklisted so that they are not preloaded on subsequent reloads. This +behavior is useful if you are actively working on a module that is normally +preloaded. + +=head2 MAKING YOUR PROJECT ALWAYS USE YATH + + $ yath init + +The above command will create C<test.pl>. C<test.pl> is automatically run by +most build utils, in which case only the exit value matters. The generated +C<test.pl> will run C<yath> and execute all tests in the C<./t> and/or C<./t2> +directories. Tests in C<./t> will ALSO be run by prove but tests in C<./t2> +will only be run by yath. + +=head2 PROJECT-SPECIFIC YATH CONFIG + +You can write a C<.yath.rc> file. The file format is very simple. Create a +C<[COMMAND]> section to start the configuration for a command and then +provide any options normally allowed by it. When C<yath> is run inside your +project, it will use the config specified in the rc file, unless overridden +by command line options. + +B<Note:> You can also add pre-command options by placing them at the top of +your config file I<BEFORE> any C<[cmd]> markers. + +Comments start with a semi-colon. + +Example .yath.rc: + + -pFoo ; Load the 'foo' plugin before dealing with commands. + + [test] + -B ;Always write a bzip2-compressed log + + [start] + -PMoose ;Always preload Moose with a persistent runner + +This file is normally committed into the project's repo. + +=head3 SPECIAL PATH PSEUDO-FUNCTIONS + +Sometimes you want to specify files relative to the .yath.rc so that the config +option works from any subdirectory of the project. Other times you may wish to +use a shell expansion. Sometimes you want both! + +=over 4 + +=item rel(path/to/file) + + -I rel(path/to/extra_lib) + -I=rel(path/to/extra_lib) + +This will take the path to C<.yath.rc> and prefix it to the path inside +C<rel(...)>. If for example you have C</project/.yath.rc> then the path would +become C</project/path/to/extra_lib>. + +=item glob(path/*/file) + + --default-search glob(subprojects/*/t) + --default-search=glob(subprojects/*/t) + +This will add a C<--default-search $_> for every item found in the glob. This +uses the perl builtin function C<glob()> under the hood. + +=item relglob(path/*/file) + + --default-search relglob(subprojects/*/t) + --default-search=relglob(subprojects/*/t) + +Same as C<glob()> except paths are relative to the C<.yath.rc> file. + +=back + +=head2 PROJECT-SPECIFIC YATH CONFIG USER OVERRIDES + +You can add a C<.yath.user.rc> file. Format is the same as the regular +C<.yath.rc> file. This file will be read in addition to the regular config +file. Directives in this file will come AFTER the directives in the primary +config so it may be used to override config. + +This file should not normally be committed to the project repo. + +=head2 HARNESS DIRECTIVES INSIDE TESTS + +C<yath> will recognise a number of directive comments placed near the top of +test files. These directives should be placed after the C<#!> line but +before any real code. + +Real code is defined as any line that does not start with use, require, BEGIN, package, or # + +=over 4 + +=item good example 1 + + #!/usr/bin/perl + # HARNESS-NO-FORK + + ... + +=item good example 2 + + #!/usr/bin/perl + use strict; + use warnings; + + # HARNESS-NO-FORK + + ... + +=item bad example 1 + + #!/usr/bin/perl + + # blah + + # HARNESS-NO-FORK + + ... + +=item bad example 2 + + #!/usr/bin/perl + + print "hi\n"; + + # HARNESS-NO-FORK + + ... + +=back + +=head3 HARNESS-NO-PRELOAD + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + +Use this if your test will fail when modules are preloaded. This will tell yath +to start a new perl process to run the script instead of forking with preloaded +modules. + +Currently this implies HARNESS-NO-FORK, but that may not always be the case. + +=head3 HARNESS-NO-FORK + + #!/usr/bin/perl + # HARNESS-NO-FORK + +Use this if your test file cannot run in a forked process, but instead must be +run directly with a new perl process. + +This implies HARNESS-NO-PRELOAD. + +=head3 HARNESS-NO-STREAM + +C<yath> usually uses the L<Test2::Formatter::Stream> formatter instead of TAP. +Some tests depend on using a TAP formatter. This option will make C<yath> use +L<Test2::Formatter::TAP> or L<Test::Builder::Formatter>. + +=head3 HARNESS-NO-IO-EVENTS + +C<yath> can be configured to use the L<Test2::Plugin::IOEvents> plugin. This +plugin replaces STDERR and STDOUT in your test with tied handles that fire off +proper L<Test2::Event>'s when they are printed to. Most of the time this is not +an issue, but any fancy tests or modules which do anything with STDERR or +STDOUT other than print may have really messy errors. + +B<Note:> This plugin is disabled by default, so you only need this directive if +you enable it globally but need to turn it back off for select tests. + +=head3 HARNESS-NO-TIMEOUT + +C<yath> will usually kill a test if no events occur within a timeout (default +60 seconds). You can add this directive to tests that are expected to trip the +timeout, but should be allowed to continue. + +NOTE: you usually are doing the wrong thing if you need to set this. See: +C<HARNESS-TIMEOUT-EVENT>. + +=head3 HARNESS-TIMEOUT-EVENT 60 + +C<yath> can be told to alter the default event timeout from 60 seconds to another +value. This is the recommended alternative to HARNESS-NO-TIMEOUT + +=head3 HARNESS-TIMEOUT-POSTEXIT 15 + +C<yath> can be told to alter the default POSTEXIT timeout from 15 seconds to another value. + +Sometimes a test will fork producing output in the child while the parent is +allowed to exit. In these cases we cannot rely on the original process exit to +tell us when a test is complete. In cases where we have an exit, and partial +output (assertions with no final plan, or a plan that has not been completed) +we wait for a timeout period to see if any additional events come into + +=head3 HARNESS-DURATION-LONG + +This lets you tell C<yath> that the test file is long-running. This is +primarily used when concurrency is turned on in order to run longer tests +earlier, and concurrently with shorter ones. There is also a C<yath> option to +skip all long tests. + +This duration is set automatically if HARNESS-NO-TIMEOUT is set. + +=head3 HARNESS-DURATION-MEDIUM + +This lets you tell C<yath> that the test is medium. + +This is the default duration. + +=head3 HARNESS-DURATION-SHORT + +This lets you tell C<yath> That the test is short. + +=head3 HARNESS-CATEGORY-ISOLATION + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests. Yath will hold off and run these tests one at a time after all other +tests. + +=head3 HARNESS-CATEGORY-IMMISCIBLE + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests of this class. This is helpful when you have multiple tests which would +otherwise have to be run sequentially at the end of the run. + +Yath prioritizes running these tests above HARNESS-CATEGORY-LONG. + +=head3 HARNESS-CATEGORY-GENERAL + +This is the default category. + +=head3 HARNESS-CONFLICTS-XXX + +This lets you tell C<yath> that no other test of type XXX can be run at the +same time as this one. You are able to set multiple conflict types and C<yath> +will honor them. + +XXX can be replaced with any type of your choosing. + +NOTE: This directive does not alter the category of your test. You are free +to mark the test with LONG or MEDIUM in addition to this marker. + +=head3 HARNESS-JOB-SLOTS 2 + +=head3 HARNESS-JOB-SLOTS 1 10 + +Specify a range of job slots needed for the test to run. If set to a single +value then the test will only run if it can have the specified number of slots. +If given a range the test will require at least the lower number of slots, and +use up to the maximum number of slots. + +=over 4 + +=item Example with multiple lines. + + #!/usr/bin/perl + # DASH and space are split the same way. + # HARNESS-CONFLICTS-DAEMON + # HARNESS-CONFLICTS MYSQL + + ... + +=item Or on a single line. + + #!/usr/bin/perl + # HARNESS-CONFLICTS DAEMON MYSQL + + ... + +=back + +=head3 HARNESS-RETRY-n + +This lets you specify a number (minimum n=1) of retries on test failure +for a specific test. HARNESS-RETRY-1 means a failing test will be run twice +and is equivalent to HARNESS-RETRY. + +=head3 HARNESS-NO-RETRY + +Use this to avoid this test being retried regardless of your retry settings. + +=head1 MODULE DOCS + +This section documents the L<App::Yath> module itself. + +=head2 SYNOPSIS + +In practice you should never need to write your own yath script, or construct +an L<App::Yath> instance, or even access themain instance when yath is running. +However some aspects of doing so are documented here for completeness. + +A minimum yath script looks like this: + + BEGIN { + package App::Yath:Script; + + require Time::HiRes; + require App::Yath; + require Test2::Harness::Settings; + + my $settings = Test2::Harness::Settings->new( + harness => { + orig_argv => [@ARGV], + orig_inc => [@INC], + script => __FILE__, + start => Time::HiRes::time(), + version => $App::Yath::VERSION, + }, + ); + + my $app = App::Yath->new( + argv => \@ARGV, + config => {}, + settings => $settings, + ); + + $app->generate_run_sub('App::Yath::Script::run'); + } + + exit(App::Yath::Script::run()); + +It is important that most logic live in a BEGIN block. This is so that +L<goto::file> can be used post-fork to execute a test script. + +The actual yath script is significantly more complicated with the following behaviors: + +=over 4 + +=item pre-process essential arguments such as -D and no-scan-plugins + +=item re-exec with a different yath script if in developer mode and a local copy is found + +=item Parse the yath-rc config files + +=item gather and store essential startup information + +=back + +=head2 METHODS + +App::Yath does not provide many methods to use externally. + +=over 4 + +=item $app->generate_run_sub($symbol_name) + +This tells App::Yath to generate a subroutine at the specified symbol name +which can be run and be expected to return an exit value. + +=item $lib_path = $app->app_path() + +Get the include directory App::Yath was loaded from. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Command.pm b/libold2/App/Yath/Command.pm new file mode 100644 index 000000000..4f49190af --- /dev/null +++ b/libold2/App/Yath/Command.pm @@ -0,0 +1,383 @@ +package App::Yath::Command; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Carp qw/croak/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::HashBase qw/-settings -args/; + +use App::Yath::Options(); + +use Test2::Harness::Util::File::JSON(); + +sub internal_only { 0 } +sub always_keep_dir { 0 } +sub summary { "No Summary" } +sub description { "No Description" } +sub group { "Z-UNFINISHED" } +sub doc_args { () } +sub only_cmd_opts { 0 } + +sub handle_invalid_option { 0 } + +sub munge_opts { } + +sub name { $_[0] =~ m/([^:=]+)(?:=.*)?$/; $1 || $_[0] } + +sub run { + my $self = shift; + + warn "This command is currently empty"; + + return 1; +} + +sub cli_help { + my $class = shift; + my %params = @_; + + my $settings = $params{settings} // {}; + my $script = $settings->harness->script // $0; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = $params{options}; + unless ($options) { + $options = App::Yath::Options->new; + $options->set_command_class($class); + } + + my ($pre_opts, $cmd_opts); + if ($options) { + $pre_opts = $options->pre_docs('cli'); + $cmd_opts = $options->cmd_docs('cli'); + } + + my $usage = "Usage: $script"; + + my @out; + + if ($pre_opts) { + $usage .= ' [YATH OPTIONS]'; + + $pre_opts =~ s/^/ /mg; + push @out => "[YATH OPTIONS]\n$pre_opts"; + } + + $usage .= " $cmd"; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + + $cmd_opts =~ s/^/ /mg; + push @out => "[COMMAND OPTIONS]\n$cmd_opts"; + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + my @desc; + for my $arg (@args) { + if (ref($arg)) { + my ($name, $text) = @$arg; + push @desc => $name; + $text =~ s/^/ /mg; + push @desc => "$text\n"; + } + else { + push @desc => "$arg\n"; + } + } + + my $desc = join "\n" => @desc; + $desc =~ s/^/ /mg; + + push @out => "[COMMAND ARGUMENTS]\n$desc"; + } + + chomp(my $desc = $class->description); + unshift @out => ("$cmd - " . $class->summary, $desc, $usage); + + return join("\n\n" => grep { $_ } @out) . "\n"; +} + +sub generate_pod { + my $class = shift; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = App::Yath::Options->new(); + require App::Yath; + my $ay = App::Yath->new(); + $options->include($ay->load_options); + $options->set_command_class($class); + my $pre_opts = $options->pre_docs('pod', 3); + my $cmd_opts = $options->cmd_docs('pod', 3); + + my $usage = " \$ yath [YATH OPTIONS] $cmd"; + + my @head2s; + + push @head2s => ("=head2 YATH OPTIONS", $pre_opts) if $pre_opts; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + push @head2s => ("=head2 COMMAND OPTIONS", $cmd_opts); + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + push @head2s => ( + "=head2 COMMAND ARGUMENTS", + "=over 4", + (map { ref($_) ? ( "=item $_->[0]", $_->[1] ) : ("=item $_") } @args), + "=back" + ); + } + + my @out = ( + "=head1 NAME", + "$class - " . $class->summary, + "=head1 DESCRIPTION", + $class->description, + "=head1 USAGE", + $usage, + @head2s + ); + + return join("\n\n" => grep { $_ } @out); +} + +sub setup_resources { + my $self = shift; + my $settings = $self->settings; + + return unless $settings->check_prefix('runner'); + my $runner = $settings->runner; + my $res = $runner->resources or return; + return unless @$res; + + for my $res (@$res) { + require(mod2file($res)) unless ref $res; + $res->setup($settings); + } +} + +sub setup_plugins { + my $self = shift; + $_->setup($self->settings) for @{$self->settings->harness->plugins}; +} + +sub teardown_plugins { + my $self = shift; + my ($renderers, $logger) = @_; + $_->teardown($self->settings, $renderers, $logger) for @{$self->settings->harness->plugins}; +} + +sub finalize_plugins { + my $self = shift; + $_->finalize($self->settings) for @{$self->settings->harness->plugins}; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Command - Base class for yath commands + +=head1 DESCRIPTION + +This is the base class for any/all yath commands. If you wish to add a new yath +command you should subclass this package. + +=head1 SYNOPSIS + + package App::Yath::Command::mycommand; + use strict; + use warnings; + + use App::Yath::Options(); + use parent 'App::Yath::Command'; + + # Include existing option sets + include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ..., + ); + + # Add some custom options + option_group {prefix => 'mycommand', category => 'mycommand options'} => sub { + option foo => ( + description => "the foo option", + default => 0, + ); + }; + + # This is used to sort/group commands in the "yath help" output + sub group { 'thirdparty' } + + # Brief 1-line summary + sub summary { "This is a third party command, it does stuff..." } + + # Longer description of the command (used in yath help mycommand) + sub description { + return <<" EOT"; + This command does: + This + That + Those + EOT + } + + # Entrypoint + sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + print "Hello Third Party!\n" + + # Return an exit value. + return 0; + } + +=head1 CLASS METHODS + +=over 4 + +=item $string = $cmd_class->cli_help(settings => $settings, options => $options) + +This method generates the command line help for any given command. In general +you will NOT want to override this. + +$settings should be an instance of L<Test2::Harness::Settings>. + +$options should be an instance of L<App::Yath::Options> if provided. This +method is usually capable of filling in the details when this is omitted. + +=item $multi_line_string = $cmd_class->description() + +Long-form description of the command. Used in C<cli_help()>. + +=item @list = $cmd_class->doc_args() + +A list of argument names to the command, used to generate documentation. + +=item $string = $cmd_class->generate_pod() + +This can be used to generate POD documentation from the command itself using +the other fields listed in this section, as well as all applicable command +lines options specified in the command. + +=item $string = $cmd_class->group() + +Used for sorting/grouping commands in the C<yath help> output. + +Existing groups: + + ' test' # Space in front to make sure test related command float up + 'log' # Log processing commands + 'persist' # Commands related to the persistent runner + 'zinit' # The init command and related command sink to the bottom. + +Unless your command OBVIOUSLY and CLEARLY belongs in one of the above groups +you should probably create your own. Please do not prefix it with a space to +make it float, C<' test'> is a special case, you are not that special. + +=item $string = $cmd_class->name() + +Name of the command. By default this is the last part of the package name. You +will probably never want to override this. + +=item $short_string = $cmd_class->summary() + +A short summary of what this command is. + +=back + +=head1 OBJECT METHODS + +=over 4 + +=item $bool = $cmd->always_keep_dir() + +By default the working directory is deleted when yath exits. Some commands such +as L<App::Yath::Command::start> need to keep the directory. Override this +method to return true if your command uses the workdir and needs to keep it. + +=item $arrayref = $cmd->args() + +Get an arrayref of command line arguments B<AFTER> options have been +process/removed. + +=item $bool = $cmd->internal_only() + +Set this to true if you do not want your command to show up in the help output. + +=item $exit_code = $cmd->run() + +This is the main entrypoint for the command. You B<MUST> override this. This +method should return an exit code. + +=item $settings = $cmd->settings() + +Get the settings as populated by the command line options. + +=item $cmd->write_settings_to($directory, $filename) + +A helper method to write the settings to a specified directory and filename. +File is written as JSON. + +If you are subclassing another command such as L<App::Yath::Command::test> you +may want to override this to a no-op to prevent the settings file from being +written, the L<App::Yath::Command:run> command does this. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Command/abort.pm b/libold2/App/Yath/Command/abort.pm new file mode 100644 index 000000000..349002f9a --- /dev/null +++ b/libold2/App/Yath/Command/abort.pm @@ -0,0 +1,68 @@ +package App::Yath::Command::abort; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; +use Term::Table; + +use File::Spec(); + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command::status'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Abort all currently running or queued tests without killing the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will kill all running tests and clear the queue, but will not close the runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + # Get the output from finding the pfile + $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + print "\nTruncating Queue...\n\n"; + $state->truncate; + $state->poll; + + my $running = $state->running_tasks; + for my $task (values %$running) { + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next;; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + + print "\n"; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/aggregator.pm b/libold2/App/Yath/Command/aggregator.pm new file mode 100644 index 000000000..dcb10d53d --- /dev/null +++ b/libold2/App/Yath/Command/aggregator.pm @@ -0,0 +1,47 @@ +package App::Yath::Command::aggregator; +use strict; +use warnings; + +use Test2::Harness::Aggregator; +use Test2::Harness::State; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +our $VERSION = '2.000000'; + +sub name { 'aggregator' } +sub group { 'z_internal' } +sub summary { "Start an aggregator process" } +sub internal_only { 1 } + +sub description { + return <<" EOT"; +An aggregator process takes events from any number of sources and combines them +into a single output stream. + EOT +} + +sub run { + my $self = shift; + my ($name, $run_id, $state_file, $fifo_file, $output_file, $parent_pid) = @{$self->{+ARGS}}; + + my $state = Test2::Harness::State->new(state_file => $state_file); + + my $aggregator = Test2::Harness::Aggregator->new( + name => $name, + run_id => $run_id, + state => $state, + fifo_file => $fifo_file, + output_file => $output_file, + ); + + return $aggregator->run($parent_pid); +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/auditor.pm b/libold2/App/Yath/Command/auditor.pm new file mode 100644 index 000000000..963840478 --- /dev/null +++ b/libold2/App/Yath/Command/auditor.pm @@ -0,0 +1,58 @@ +package App::Yath::Command::auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Scalar::Util qw/blessed/; + +use App::Yath::Util qw/isolate_stdout/; + +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Run; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'auditor' } + +sub run { + my $self = shift; + my ($auditor_class, $run_id, %args) = @{$self->{+ARGS}}; + + my $name = 'yath-auditor'; + $name = "$args{procname_prefix}-${name}" if $args{procname_prefix}; + $0 = $name; + + my $fh = isolate_stdout(); + + require(mod2file($auditor_class)); + + my $auditor = $auditor_class->new( + %args, + run_id => $run_id, + action => sub { print $fh defined($_[0]) ? blessed($_[0]) ? $_[0]->as_json . "\n" : encode_json($_[0]) . "\n" : "null\n" }, + ); + + local $SIG{PIPE} = 'IGNORE'; + my $ok = eval { $auditor->process(); 1 }; + my $err = $@; + + eval { $auditor->finish(); 1 } or warn $@; + + die $err unless $ok; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/collector.pm b/libold2/App/Yath/Command/collector.pm new file mode 100644 index 000000000..f96e2c5f8 --- /dev/null +++ b/libold2/App/Yath/Command/collector.pm @@ -0,0 +1,266 @@ +package App::Yath::Command::collector; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Time::HiRes qw/sleep time/; +use Test2::Harness::Util qw/fqmod clean_path mod2file/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use Test2::Harness::State; +use Test2::Harness::Collector; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw{ + +state + +writer +}; + +include_options( + 'App::Yath::Options::Debug', +); + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'collector' } + +option_group {prefix => 'collector', category => 'collector options'} => sub { + option parser => ( + type => 's', + default => 'Test2::Harness::Collector::IOParser', + description => "The parser to use when reading from stderr and stdout.", + long_examples => [' IOParser', ' Stream'], + short_examples => [' IOParser', ' Stream'], + normalize => sub { fqmod('Test2::Harness::Collector::IOParser', $_[0]) }, + ); + + option auditor => ( + type => 'd', + description => "Enable or specify an auditor", + long_examples => ['', '=Auditor'], + short_examples => ['', '=Auditor'], + normalize => sub { fqmod('Test2::Harness::Collector::Auditor', $_[0]) }, + autofill => '+Test2::Harness::Collector::Auditor', + ); + + option aggregator => ( + type => 's', + description => "What aggregator should receive the events (also requires a state file)", + long_examples => [' runner', ' renderer'], + short_examples => [' runner', ' renderer'], + ); + + option aggregator_timeout => ( + type => 's', + description => 'Timeout when waiting for the aggregator to show up in the state file', + default => 10, + long_examples => [' 10'], + short_examples => [' 10'], + ); + + option state_file => ( + type => 's', + description => "State file for the yath instance", + long_examples => [' /path/to/statefile'], + short_examples => [' /path/to/statefile'], + normalize => \&clean_path, + ); + + option output_file => ( + type => 's', + description => "Output file to use instead of an aggregator or stdout", + long_examples => [' /path/to/output.jsonl'], + short_examples => [' /path/to/output.jsonl'], + normalize => \&clean_path, + ); + + option summary_file => ( + type => 's', + description => "Summary file that will contain an up-to-date summary status as the test runs, and a final state when test is complete", + long_examples => [' /path/to/summary.json'], + short_examples => [' /path/to/summary.json'], + normalize => \&clean_path, + ); + + option merge_io => ( + type => 'b', + description => "Merge STDOUT and STDERR into a single stream", + default => 0, + ); + + option run_id => ( + type => 's', + default => 0, + description => 'Run ID to use for parsed events', + ); + + option job_id => ( + type => 's', + default => 0, + description => 'Job ID to use for parsed events', + ); + + option job_try => ( + type => 's', + default => 0, + description => 'Job Try', + ); + + option parent_pid => ( + type => 's', + default => sub { getppid() }, + description => 'Pid of parent process', + ); + + option type => ( + type => 's', + description => "Type of process being collected", + default => 'unknown', + ); + + option name => ( + type => 's', + description => "Name of process being collected", + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables to set when each test is run.', + ); +}; + +sub state { + my $self = shift; + + return $self->{+STATE} if $self->{+STATE}; + + my $settings = $self->settings; + + my $state_file = $settings->collector->state_file or die "'state_file' is a required argument.\n"; + if (-e $state_file) { + return $self->{+STATE} = Test2::Harness::State->new(state_file => $state_file); + } + else { + return $self->{+STATE} = Test2::Harness::State->new(state_file => $state_file, settings => $settings); + } +} + +sub writer { + my $self = shift; + + return $self->{+WRITER} if $self->{+WRITER}; + + my $settings = $self->settings; + + if (my $agg = $settings->collector->aggregator) { + my $state = $self->state; + + my $timeout = $settings->collector->aggregator_timeout; + my $start = time; + my $agg_data; + + while (!$agg_data) { + $state->transaction(r => sub { + my ($state, $data) = @_; + $agg_data = $data->aggregators->{$agg}; + }); + + die "Timed out waiting for aggregator ($agg) after $timeout seconds.\n" if (time - $start) > $timeout; + sleep 0.2 unless $agg_data; + } + + require Atomic::Pipe; + my $w = Atomic::Pipe->write_fifo($agg_data->{fifo}); + + return $self->{+WRITER} = sub { $w->write_message(encode_json($_[0])) }; + } + + if (my $out_file = $settings->collector->output_file) { + die "Output file '$out_file' already exists!\n" if -e $out_file; + require Test2::Harness::Util::File::JSONL; + my $of = Test2::Harness::Util::File::JSONL->new(name => $out_file); + return $self->{+WRITER} = sub { $of->write($_[0]) }; + } + + return $self->{+WRITER} = sub { print STDOUT encode_json($_[0]), "\n" }; +} + +sub run { + my $self = shift; + my @exec = @{$self->args // []}; + shift @exec while @exec && $exec[0] eq '--'; + + my $settings = $self->settings; + + my $writer = $self->writer; + + # Init the stream parser + my $parser_class = $settings->collector->parser; + require(mod2file($parser_class)); + my $parser = $parser_class->new( + run_id => $settings->collector->run_id, + job_id => $settings->collector->job_id, + job_try => $settings->collector->job_try, + name => $settings->collector->name // join(' ' => @exec), + type => $settings->collector->type, + ); + + my $name = $settings->collector->name // join(' ' => @exec); + + my $event_cb; + if (my $auditor_class = $settings->collector->auditor) { + require(mod2file($auditor_class)); + my $auditor = $auditor_class->new( + file => $name, + run_id => $settings->collector->run_id, + job_id => $settings->collector->job_id, + job_try => $settings->collector->job_try, + summary_file => $settings->collector->summary_file, + state => $self->state, + ); + + $event_cb = sub { + my @events = ($_[1]); + @events = map { $parser->parse_io($_) } @events; + @events = map { $auditor->audit($_) } @events; + $writer->($_) for @events; + }; + } + else { + $event_cb = sub { $writer->($_) for $parser->parse_io($_[1]) }; + } + + my $collector = Test2::Harness::Collector->new( + state => $self->state, + merge_outputs => $self->settings->collector->merge_io, + event_cb => $event_cb, + run_id => $settings->collector->run_id, + job_id => $settings->collector->job_id, + job_try => $settings->collector->job_try, + ); + + # Start the child + $collector->run( + name => $name, + type => $settings->collector->type, + env => $settings->collector->env_vars, + parent_pid => $settings->collector->parent_pid, + launch_cb => sub { exec(@exec) }, + ); + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/do.pm b/libold2/App/Yath/Command/do.pm new file mode 100644 index 000000000..d4535b491 --- /dev/null +++ b/libold2/App/Yath/Command/do.pm @@ -0,0 +1,41 @@ +package App::Yath::Command::do; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::File::JSON; + +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { '' } + +sub summary { "Run tests using 'run' or 'test', same as the default command, but explicit." } +sub cli_args { "[run or test args]" } + +sub description { + return <<" EOT"; +This is the same as running yath without a command, except that it will not +fail on CLI parsing issues that often get mistaken for commands. + +If there is a persistent runner then the 'run' command is used, otherwise the +'test' command is used. + EOT +} + +sub run { + # This file is actually just a stub for the magic of 'do'. Code is not executed. + die "This should not be reachable"; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + + diff --git a/libold2/App/Yath/Command/failed.pm b/libold2/App/Yath/Command/failed.pm new file mode 100644 index 000000000..ff05e3681 --- /dev/null +++ b/libold2/App/Yath/Command/failed.pm @@ -0,0 +1,147 @@ +package App::Yath::Command::failed; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Table qw/table/; +use Test2::Harness::Util::File::JSONL; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw{<log_file}; + +use App::Yath::Options; + +option brief => ( + prefix => 'display', + category => 'Display Options', + description => 'Show only the files that failed, newline separated, no other output. If a file failed once but passed on a retry it will NOT be shown.', +); + +sub summary { "Show the failed tests from an event log" } + +sub group { 'log' } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [job1, job2, ...]" } + +sub description { + return <<" EOT"; +This yath command will list the test scripts from an event log that have failed. +The only required argument is the path to the log file, which may be compressed. +Any extra arguments are assumed to be job id's. If you list any jobs, +only the listed jobs will be processed. + +This command accepts all the same renderer/formatter options that the 'test' +command accepts. + EOT +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my %failed; + + while(1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + push @{$failed{$job_id}->{subtests}} => $self->subtests($f) + if $f->{parent} && !$f->{trace}->{nested} && $self->include_subtest($f); + + next unless $f->{harness_job_end}; + next unless $f->{harness_job_end}->{fail} || $failed{$job_id}; + + push @{$failed{$job_id}->{ends}} => $f->{harness_job_end}; + } + } + + my $rows = []; + while (my ($job_id, $data) = each %failed) { + my $ends = $data->{ends} // []; + + my %seen; + my $subtests = join "\n" => grep { !$seen{$_}++ } sort @{$data->{subtests} // []}; + + if ($settings->display->brief) { + print $ends->[-1]->{rel_file}, "\n" if $ends->[-1]->{fail}; + } + else { + push @$rows => [$job_id, scalar(@$ends), $ends->[-1]->{rel_file}, $subtests, $ends->[-1]->{fail} ? "NO" : "YES"]; + } + } + + return 0 if $settings->display->brief; + + unless (@$rows) { + print "\nNo jobs failed!\n"; + return 0; + } + + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Times Run', 'Test File', "Subtests", "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + + return 0; +} + +sub include_subtest { + my $self = shift; + my ($f) = @_; + + return 0 unless $f->{parent} && keys %{$f->{parent}}; + return 0 if $f->{assert}->{pass} || !keys %{$f->{assert}}; + return 0 if $f->{amnesty} && @{$f->{amnesty}}; + return 1; +} + +sub subtests { + my $self = shift; + my ($f, $prefix) = @_; + + return unless $self->include_subtest($f); + + my $name = $f->{assert}->{details}; + unless ($name) { + my $frame = $f->{trace}->{frame}; + $name = "Unnamed Subtest"; + $name .= " ($frame->[1] line $frame->[2])" if $frame->[1] && $frame->[2]; + } + + $name = "$prefix -> $name" if $prefix; + + my @out; + push @out => $name; + for my $child (@{$f->{parent}->{children}}) { + next unless $child->{parent}; + push @out => $self->subtests($child, $name); + } + + return @out; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/help.pm b/libold2/App/Yath/Command/help.pm new file mode 100644 index 000000000..ff1224c98 --- /dev/null +++ b/libold2/App/Yath/Command/help.pm @@ -0,0 +1,96 @@ +package App::Yath::Command::help; +use strict; +use warnings; + +use Test2::Util qw/pkg_to_file/; + +our $VERSION = '1.000152'; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/<_command_info_hash/; + +use Test2::Harness::Util qw/open_file find_libraries/; +use List::Util (); + +sub options {}; +sub group { '' } +sub summary { 'Show the list of commands' } + +sub description { + return <<" EOT" +This command provides a list of commands when called with no arguments. +When given a command name as an argument it will print the help for that +command. + EOT +} + +sub command_info_hash { + my $self = shift; + + return $self->{+_COMMAND_INFO_HASH} if $self->{+_COMMAND_INFO_HASH}; + + my %commands; + my $command_libs = find_libraries('App::Yath::Command::*'); + for my $lib (sort keys %$command_libs) { + my $ok = eval { require $command_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load command '$command_libs->{$lib}': $@"; + next; + } + + next if $lib->internal_only; + my $name = $lib->name; + my $group = $lib->group; + $commands{$group}->{$name} = $lib->summary; + } + + return $self->{+_COMMAND_INFO_HASH} = \%commands; +} + +sub command_list { + my $self = shift; + + my $command_hash = $self->command_info_hash(); + my @commands = map keys %$_, values %$command_hash; + return @commands; +} + +sub run { + my $self = shift; + my $args = $self->{+ARGS}; + + return $self->command_help($args->[0]) if @$args; + + my $script = $self->settings->harness->script // $0; + my $maxlen = List::Util::max(map length, $self->command_list); + + print "\nUsage: $script COMMAND [options]\n\nAvailable Commands:\n"; + + my $command_info_hash = $self->command_info_hash; + for my $group (sort keys %$command_info_hash) { + my $set = $command_info_hash->{$group}; + + printf(" %${maxlen}s: %s\n", $_, $set->{$_}) for sort keys %$set; + print "\n"; + } + + return 0; +} + +sub command_help { + my $self = shift; + my ($command) = @_; + + require App::Yath; + my $cmd_class = App::Yath->load_command($command); + print $cmd_class->cli_help(settings => $self->{+SETTINGS}); + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/init.pm b/libold2/App/Yath/Command/init.pm new file mode 100644 index 000000000..abb282703 --- /dev/null +++ b/libold2/App/Yath/Command/init.pm @@ -0,0 +1,66 @@ +package App::Yath::Command::init; +use strict; +use warnings; + +use parent 'App::Yath::Command'; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/open_file/; +use App::Yath::Util qw/is_generated_test_pl/; + +sub group { 'zinit' } + +sub summary { "Create/update test.pl to run tests via Test2::Harness" } + +sub description { + return <<" EOT"; +This command will create or update the 'test.pl' file in the current directory. +This 'test.pl' file this creates will run all your tests via yath. + +This command will fail if there is already a test.pl file that does not look +like it was generated by this command. + EOT +} + +sub run { + die "'test.pl' already exists, and does not appear to be a yath runner.\n" + if -f 'test.pl' && !is_generated_test_pl('test.pl'); + + print "\nWriting test.pl...\n\n"; + + my $fh = open_file('test.pl', '>'); + + print $fh <<' EOT'; +#!/usr/bin/env perl +# HARNESS-NO-PRELOAD +# HARNESS-CAT-LONG +# THIS IS A GENERATED YATH RUNNER TEST +use strict; +use warnings; + +use lib 'lib'; +use App::Yath::Util qw/find_yath/; + +system($^X, find_yath(), '-D', 'test', '--default-search' => './t', '--default-search' => './t2', @ARGV); +my $exit = $?; + +# This makes sure it works with prove. +print "1..1\n"; +print "not " if $exit; +print "ok 1 - Passed tests when run by yath\n"; +print STDERR "yath exited with $exit" if $exit; + +exit($exit ? 255 : 0); + EOT + + return 0; +} + +1; + + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/kill.pm b/libold2/App/Yath/Command/kill.pm new file mode 100644 index 000000000..ebb379bc6 --- /dev/null +++ b/libold2/App/Yath/Command/kill.pm @@ -0,0 +1,54 @@ +package App::Yath::Command::kill; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; +use App::Yath::Util qw/find_pfile/; +use File::Path qw/remove_tree/; + +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::abort'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Kill the runner and any running or pending tests" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will kill the active yath runner and any running or pending tests. + EOT +} + +sub pfile_params { (no_checks => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + my $pfile = $data->{pfile_path}; + + $self->App::Yath::Command::test::terminate_queue(); + + $_->teardown($self->settings) for @{$self->settings->harness->plugins}; + + $self->SUPER::run(); + + sleep(0.02) while kill(0, $self->pfile_data->{pid}); + unlink($pfile) if -f $pfile; + remove_tree($self->workdir, {safe => 1, keep_root => 0}) if -d $self->workdir; + print "\n\nRunner stopped\n\n" unless $self->settings->display->quiet; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/one.pm b/libold2/App/Yath/Command/one.pm new file mode 100644 index 000000000..03ab05c57 --- /dev/null +++ b/libold2/App/Yath/Command/one.pm @@ -0,0 +1,90 @@ +package App::Yath::Command::one; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw{}; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Workspace', +); + +option_group {prefix => 'collector', category => 'collector options'} => sub { + option parser => ( + type => 's', + default => 'Test2::Harness::Collector::IOParser::Stream', + description => "The parser to use when reading from stderr and stdout.", + long_examples => [' IOParser', ' Stream'], + short_examples => [' IOParser', ' Stream'], + normalize => sub { fqmod('Test2::Harness::Collector::IOParser', $_[0]) }, + ); + + option auditor => ( + type => 'd', + description => "Enable or specify an auditor", + long_examples => ['', '=Auditor'], + short_examples => ['', '=Auditor'], + normalize => sub { fqmod('Test2::Harness::Collector::Auditor', $_[0]) }, + autofill => '+Test2::Harness::Collector::Auditor', + ); + + option summary_file => ( + type => 's', + description => "Summary file that will contain an up-to-date summary status as the test runs, and a final state when test is complete", + long_examples => [' /path/to/summary.json'], + short_examples => [' /path/to/summary.json'], + normalize => \&clean_path, + ); + + option merge_io => ( + type => 'b', + description => "Merge STDOUT and STDERR into a single stream", + default => 0, + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables to set when each test is run.', + ); +}; + +sub internal_only { 0 } +sub summary { "Run a single test, no preload, no plugins, no resources, nothing magic" } +sub name { 'one' } + +sub run { + my $self = shift; + + my ($file, @args) = @{$self->args // []}; + @args = grep { $_ ne '::' } @args; + + my $settings = $self->settings; + + # start the process manager + # start the renderer + # start the collector+job + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + +# perl -Ilib scripts/yath -D collector --type test --state-file 'mystate' --job-try 3 --parser Stream --env -var AUTHOR_TESTING=1 --env-var T2_FORMATTER=Stream --auditor --job-id 55 --summary-file foo --name t2/subt ests.t +# -- perl -Ilib t2/subtests.t +# | perl -Ilib scripts/yath -D render -v + + diff --git a/libold2/App/Yath/Command/projects.pm b/libold2/App/Yath/Command/projects.pm new file mode 100644 index 000000000..4f3d866cd --- /dev/null +++ b/libold2/App/Yath/Command/projects.pm @@ -0,0 +1,26 @@ +package App::Yath::Command::projects; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'App::Yath::Command::test'; +use Test2::Harness::Util::HashBase; + +sub summary { "Run tests for multiple projects" } +sub cli_args { "[--] projects_dir [::] [arguments to test scripts]" } + +sub description { + return <<" EOT"; +This command will run all the tests for each project within a parent directory. + EOT +} + +sub finder_args {(multi_project => 1)} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/ps.pm b/libold2/App/Yath/Command/ps.pm new file mode 100644 index 000000000..b29c63691 --- /dev/null +++ b/libold2/App/Yath/Command/ps.pm @@ -0,0 +1,76 @@ +package App::Yath::Command::ps; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::status'; +use Test2::Harness::Util::HashBase qw/queue/; + +sub group { 'persist' } + +sub summary { "Process list for the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +List all running processes and runner stages. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + my @jobs; + + my $stage_status = $state->stage_readiness // {}; + for my $stage (keys %$stage_status) { + my $pid = $stage_status->{$stage} // next; + $pid = 'N/A' if $pid == 1; + push @jobs => [$pid, "Runner Stage", $stage]; + } + + my $running = $state->running_tasks; + for my $task (values %$running) { + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // 'N/A'; + my $file = $task->{rel_file}; + push @jobs => [$pid, "Running Test", $file]; + } + + my $process_table = Term::Table->new( + collapse => 1, + header => [qw/pid type name/], + rows => [sort { $a->[0] <=> $b->[0] } @jobs], + ); + + print "\n**** Running Processes ****\n"; + print "$_\n" for $process_table->render; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/reload.pm b/libold2/App/Yath/Command/reload.pm new file mode 100644 index 000000000..6ccb283af --- /dev/null +++ b/libold2/App/Yath/Command/reload.pm @@ -0,0 +1,52 @@ +package App::Yath::Command::reload; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); +use Test2::Harness::Util::File::JSON; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Reload the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This will send a SIGHUP to the persistent runner, forcing it to reload. This +will also clear the blacklist allowing all preloads to load as normal. + EOT +} + +sub run { + my $self = shift; + + my $pfile = find_pfile($self->settings, no_fatal => 1) + or die "Could not find a persistent yath running.\n"; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + + my $blacklist = File::Spec->catfile($data->{dir}, 'BLACKLIST'); + if (-e $blacklist) { + print "Deleting module blacklist...\n"; + unlink($blacklist) or warn "Could not delete blacklist file!"; + } + + print "\nSending SIGHUP to $data->{pid}\n\n"; + kill('HUP', $data->{pid}) or die "Could not send signal!\n"; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/render.pm b/libold2/App/Yath/Command/render.pm new file mode 100644 index 000000000..3a87b0c55 --- /dev/null +++ b/libold2/App/Yath/Command/render.pm @@ -0,0 +1,115 @@ +package App::Yath::Command::render; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util qw/mod2file/; +use Test2::Harness::Util::JSON qw/decode_json encode_pretty_json/; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw{ + +renderers +}; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', +); + +option_group {prefix => 'display', category => "Display Options"} => sub { + option json => ( + type => 'b', + default => 0, + description => "Render JSON", + ); + + option json_only => ( + type => 'b', + default => 0, + description => "Render JSON only", + ); +}; + +sub internal_only { 0 } +sub summary { "Render log files or STDIN" } +sub name { 'render' } + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + return $self->{+RENDERERS} = [] + if $settings->display->json_only; + + my @renderers; + + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub run { + my $self = shift; + my @files = @{$self->args // []}; + shift @files while @files && $files[0] eq '--'; + + my $settings = $self->settings; + + if (@files) { + for my $file (@files) { + require Test2::Harness::Util::File::Stream; + my $stream = Test2::Harness::Util::File::Stream->new(name => $file); + my @buffer; + $self->render(sub { + return shift(@buffer) if @buffer; + push @buffer => $stream->poll(max => 1); + return shift(@buffer) if @buffer; + return (); + }); + } + } + else { + $self->render(sub { <STDIN> }); + } + + return 0; +} + +sub render { + my $self = shift; + my ($read) = @_; + + my $dset = $self->settings->display; + + my $renderers = $self->renderers; + + while (my $json = $read->()) { + my $event = decode_json($json); + next unless $event; + + if ($dset->json || $dset->json_only) { + print STDOUT encode_pretty_json($event); + } + + next if $dset->json_only; + $_->render_event($event) for @$renderers; + } +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/replay.pm b/libold2/App/Yath/Command/replay.pm new file mode 100644 index 000000000..375c4ddf7 --- /dev/null +++ b/libold2/App/Yath/Command/replay.pm @@ -0,0 +1,109 @@ +package App::Yath::Command::replay; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; +require App::Yath::Command::test; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/+renderers <final_data <log_file <tests_seen <asserts_seen/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::PreCommand', +); + + +sub group { 'log' } + +sub summary { "Replay a test run from an event log" } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [job1, job2, ...]" } + +sub description { + return <<" EOT"; +This yath command will re-run the harness against an event log produced by a +previous test run. The only required argument is the path to the log file, +which maybe compressed. Any extra arguments are assumed to be job id's. If you +list any jobs, only listed jobs will be processed. + +This command accepts all the same renderer/formatter options that the 'test' +command accepts. + EOT +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; +} + +sub run { + my $self = shift; + + my $args = $self->args; + my $settings = $self->settings; + my $renderers = $self->App::Yath::Command::test::renderers; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my $jobs = @$args ? {map {$_ => 1} @$args} : undef; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $e (@events) { + last unless defined $e; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + if ($jobs) { + my $f = $e->{facet_data}->{harness_job_start} // $e->{facet_data}->{harness_job_queued}; + if ($f && !$jobs->{$e->{job_id}}) { + for my $field (qw/rel_file abs_file file/) { + my $file = $f->{$field} or next; + next unless $jobs->{$file}; + $jobs->{$e->{job_id}} = 1; + last; + } + } + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + else { + next if $jobs && !$jobs->{$e->{job_id}}; + $_->render_event($e) for @$renderers; + } + } + } + + $_->finish() for @$renderers; + + my $final_data = $self->{+FINAL_DATA} or die "Log did not contain final data!\n"; + + $self->App::Yath::Command::test::render_final_data($final_data); + $self->App::Yath::Command::test::render_summary($final_data->{pass}); + + return $final_data->{pass} ? 0 : 1; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/resources.pm b/libold2/App/Yath/Command/resources.pm similarity index 89% rename from lib/App/Yath/Command/resources.pm rename to libold2/App/Yath/Command/resources.pm index d52e514a7..c83698e69 100644 --- a/lib/App/Yath/Command/resources.pm +++ b/libold2/App/Yath/Command/resources.pm @@ -11,9 +11,9 @@ use Time::HiRes qw/sleep/; use App::Yath::Util qw/find_pfile/; use App::Yath::Options; +use Test2::Harness::State; use Test2::Harness::Runner::State; use Test2::Harness::Util::File::JSON(); -use Test2::Harness::Util::Queue(); use parent 'App::Yath::Command'; use Test2::Harness::Util::HashBase qw/+state/; @@ -68,13 +68,14 @@ sub state { } if (my $pfile = find_pfile($self->settings, no_fatal => 1)) { - my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); - my $workdir = $data->{dir}; - my $settings = Test2::Harness::Util::File::JSON->new(name => "$workdir/settings.json")->read(); + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + my $workdir = $data->{dir}; + my $all_state = Test2::Harness::State->new(workdir => $workdir); return $self->{+STATE} = Test2::Harness::Runner::State->new( - observe => 1, - job_count => $settings->{runner}->{job_count} // 1, + all_state => $all_state, + observe => 1, + job_count => $all_state->job_count // 1, workdir => $data->{dir}, ); } diff --git a/libold2/App/Yath/Command/run.pm b/libold2/App/Yath/Command/run.pm new file mode 100644 index 000000000..f5a6b49f2 --- /dev/null +++ b/libold2/App/Yath/Command/run.pm @@ -0,0 +1,242 @@ +package App::Yath::Command::run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; +use Test2::Harness::Util qw/mod2file open_file/; +use Test2::Util::Table qw/table/; + +use File::Spec; + +use Carp qw/croak/; + +use parent 'App::Yath::Command::test'; +use Test2::Harness::Util::HashBase qw/+pfile_data +pfile/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Finder', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Run', +); + +option_group {prefix => 'run'} => sub { + option check_reload_state => ( + type => 'b', + description => 'Abort the run if there are unfixes reload errors and show a confirmation dialogue for unfixed reload warnings.', + default => 1, + ); +}; + + +sub group { 'persist' } + +sub summary { "Run tests using the persistent test runner" } +sub cli_args { '[--] [test files/dirs] [::] [arguments to test scripts] [test_file.t] [test_file2.t="--arg1 --arg2 --param=\'foo bar\'"] [:: --argv-for-all-tests]' } + +sub description { + return <<" EOT"; +This command will run tests through an already started persistent instance. See +the start command for details on how to launch a persistant instance. + EOT +} + +sub write_settings_to {} +sub setup_plugins {} +sub setup_resources {} +sub teardown_plugins {} +sub finalize_plugins {} +sub pfile_params { () } + + +sub monitor_preloads { 1 } +sub job_count { 1 } + +sub collector_options { (persistent_runner => 1) } + +sub terminate_queue { + my $self = shift; + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + return unless exists $queue->{$self->{+RUN_ID}}; + $queue->{$self->{+RUN_ID}}->{closed} = 1; + }); +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + + if ($settings->run->check_reload_state) { + return 255 unless $self->check_reload_state; + } + + return $self->SUPER::run(@_); +} + +sub write_test_info { + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; +} + +sub check_reload_state { + my $self = shift; + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + my $reload_status = $state->reload_state // {}; + + my (@out, $errors, $warnings, %seen); + for my $stage (sort keys %$reload_status) { + for my $file (keys %{$reload_status->{$stage}}) { + next if $seen{$file}++; + my $data = $reload_status->{$stage}->{$file} or next; + + push @out => "\n==== SOURCE FILE: $file ====\n"; + if ($data->{error}) { + $errors++; + push @out => $data->{error}; + } + + for (@{$data->{warnings} // []}) { + push @out => $_; + $warnings++; + } + } + } + $errors //= 0; + $warnings //= 0; + + return 1 unless @out || $errors || $warnings; + + print <<" EOT", @out; +******************************************************************************* +* Some source files were reloaded with errors or warnings +* Errors: $errors +* Warnings: $warnings +******************************************************************************* + + EOT + + if ($errors) { + print <<" EOT"; + +******************************************************************************* +Aborting due to reload errors. Please fix the errors so that the modules reload +cleanly, then try the run again. In most cases you will not need to reload the +runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + + EOT + + return 0; + } + elsif ($warnings) { + print <<" EOT"; + +******************************************************************************* +Warnings were encountered when reloading source files, please see the output +above. If these warnings are a problem you should abort this run (control+c) +and correct them before trying again. In most cases you will not need to reload +the runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + +If these warnings are not indicitive of a problem you may continue by pressing +enter/return. + + EOT + + if (-t STDIN) { + my $ignore = <STDIN>; + return 1; + } + else { + print STDERR "No TTY detected, aborting run due to warnings...\n"; + return 0; + } + } + + return 0; +} + +sub init { + my $self = shift; + + my $settings = $self->settings; + my $pdata = $self->pfile_data; + + my $all_state = Test2::Harness::State->new(workdir => $pdata->{dir}); + my $runner_settings = $all_state->data->settings; + + for my $prefix (sort keys %{$runner_settings}) { + next if $settings->check_prefix($prefix); + + my $new = $settings->define_prefix($prefix); + ${$new->vivify_field('from_runner')} = 1; + for my $key (sort keys %{$runner_settings->{$prefix}}) { + ${$new->vivify_field($key)} = $runner_settings->{$prefix}->{$key}; + } + } + + return $self->SUPER::init(@_); +} + +sub pfile { + my $self = shift; + $self->{+PFILE} //= find_pfile($self->settings, $self->pfile_params) or die "No persistent harness was found for the current path.\n"; +} + +sub pfile_data { + my $self = shift; + return $self->{+PFILE_DATA} if $self->{+PFILE_DATA}; + + my $pfile = $self->pfile; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + $data->{pfile_path} //= $pfile; + + print "\nFound: $data->{pfile_path}\n"; + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + + return $self->{+PFILE_DATA} = $data; +} + +sub workdir { + my $self = shift; + return $self->pfile_data->{dir}; +} + +sub start_runner { + my $self = shift; + + my $data = $self->pfile_data; + + $self->{+RUNNER_PID} = $data->{pid}; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/lib/App/Yath/Command/runner.pm b/libold2/App/Yath/Command/runner.pm similarity index 98% rename from lib/App/Yath/Command/runner.pm rename to libold2/App/Yath/Command/runner.pm index 808d2dcd3..a7acdb816 100644 --- a/lib/App/Yath/Command/runner.pm +++ b/libold2/App/Yath/Command/runner.pm @@ -71,6 +71,7 @@ BEGIN { } use Test2::Harness::IPC(); +use Test2::Harness::State; use Carp qw/confess/; use Scalar::Util qw/openhandle/; @@ -116,7 +117,8 @@ sub generate_run_sub { $RUNNER_PID = $$; my $runner_pid = $$; - my $settings = Test2::Harness::Settings->new(File::Spec->catfile($dir, 'settings.json')); + my $all_state = Test2::Harness::State->new(workdir => $dir); + my $settings = $all_state->settings; my $name = $ENV{NESTED_YATH} ? 'yath-nested-runner' : 'yath-runner'; $name = $settings->debug->procname_prefix . "-${name}" if $settings->debug->procname_prefix; @@ -146,8 +148,9 @@ sub generate_run_sub { %args, - dir => $dir, - settings => $settings, + dir => $dir, + settings => $settings, + all_state => $all_state, fork_job_callback => sub { $class->launch_via_fork(@_) }, fork_spawn_callback => sub { $class->launch_spawn(@_) }, diff --git a/libold2/App/Yath/Command/spawn.pm b/libold2/App/Yath/Command/spawn.pm new file mode 100644 index 000000000..0a651a373 --- /dev/null +++ b/libold2/App/Yath/Command/spawn.pm @@ -0,0 +1,205 @@ +package App::Yath::Command::spawn; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Time::HiRes qw/sleep time/; +use File::Temp qw/tempfile/; + +use Test2::Harness::Util qw/parse_exit/; + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Launch a perl script from the preloaded environment" } +sub cli_args { "[--] path/to/script.pl [options and args]" } + +sub description { + return <<" EOT"; +This will launch the specified script from the preloaded yath process. + +NOTE: environment variables are not automatically passed to the spawned +process. You must use -e or -E (see help) to specify what environment variables +you care about. + EOT +} + +option_group {prefix => 'spawn', category => 'spawn options'} => sub { + option stage => ( + short => 's', + type => 's', + description => 'Specify the stage to be used for launching the script', + long_examples => [ ' foo'], + short_examples => [ ' foo'], + default => 'default', + ); + + option copy_env => ( + short => 'e', + type => 'm', + description => "Specify environment variables to pass along with their current values, can also use a regex", + long_examples => [ ' HOME', ' SHELL', ' /PERL_.*/i' ], + short_examples => [ ' HOME', ' SHELL', ' /PERL_.*/i' ], + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables for the spawn', + ); +}; + +sub read_line { + my ($fh, $timeout) = @_; + + $timeout //= 300; + + my $start = time; + while (1) { + if ($timeout < (time - $start)) { + my @caller = caller; + die "Timed out at $caller[1] line $caller[2].\n"; + } + seek($fh, 0,1) if eof($fh); + my $out = <$fh> // next; + chomp($out); + return $out; + } +} + +# This is here for subclasses +sub queue_spawn { + my $self = shift; + my ($args) = @_; + + $self->state->queue_spawn($args); +} + +sub run_script { shift @ARGV // die "No script specified" } + +sub stage { $_[0]->settings->spawn->stage } + +sub env_vars { + my $self = shift; + + my $settings = $self->settings; + + my $env = {}; + + for my $var (@{$settings->spawn->copy_env}) { + if ($var =~ m{^/(.*)/(\w*)$}s) { + my ($re, $opts) = ($1, $2); + my $pattern = length($opts) ? "(?$opts)$re" : $re; + $env->{$_} = $ENV{$_} for grep { m/$pattern/ } keys %ENV; + } + else { + $env->{$var} = $ENV{$var}; + } + } + + my $set = $settings->spawn->env_vars; + $env->{$_} = $set->{$_} for keys %$set; + + return $env; +} + +sub set_pname { + my $self = shift; + my ($run) = @_; + + $0 = "yath-" . $self->name . " $run " . join (' ', @ARGV); +} + +sub pre_process_argv { + shift @ARGV if @ARGV && $ARGV[0] eq '--'; +} + +sub sig_handlers { qw/INT TERM HUP QUIT USR1 USR2 STOP WINCH/ } + +sub set_sig_handlers { + my $self = shift; + my ($wpid) = @_; + + local $@; + eval { my $s = $_; $SIG{$s} = sub { kill($s, $wpid) } } for $self->sig_handlers; +} + +sub clear_sig_handlers { + my $self = shift; + + local $@; + eval { my $s = $_; $SIG{$s} = 'DEFAULT' } for $self->sig_handlers; +} + +sub pre_exit_hook {} + +sub run { + my $self = shift; + + $self->pre_process_argv; + + my $run = $self->run_script; + $self->set_pname($run); + + my ($fh, $name) = tempfile(UNLINK => 1); + close($fh); + + $self->queue_spawn({ + stage => $self->stage // 'default', + file => $run, + owner => $$, + ipcfile => $name, + args => [@ARGV], + env_vars => $self->env_vars, + }); + + open($fh, '<', $name) or die "Could not open ipcfile: $!"; + my $mpid = read_line($fh); + my $wpid = read_line($fh); + my $win = read_line($fh); + + $self->set_sig_handlers($wpid); + + open(my $wfh, '>>', "/proc/$mpid/fd/$win") or die "Could not open /proc/$wpid/fd/$win: $!"; + $wfh->autoflush(1); + STDIN->blocking(0); + while (0 < kill(0, $mpid)) { + my $line = <STDIN>; + if (defined $line) { + print $wfh $line; + } + else { + sleep 0.2; + } + } + + $self->clear_sig_handlers(); + + my $exit = read_line($fh) // die "Could not get exit code"; + $exit = parse_exit($exit); + if ($exit->{sig}) { + print STDERR "Terminated with signal: $exit->{sig}.\n"; + kill($exit->{sig}, $$); + } + + print STDERR "Exited with code: $exit->{err}.\n" if $exit->{err}; + + $self->pre_exit_hook($exit); + + exit($exit->{err}); +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/speedtag.pm b/libold2/App/Yath/Command/speedtag.pm new file mode 100644 index 000000000..661ee8753 --- /dev/null +++ b/libold2/App/Yath/Command/speedtag.pm @@ -0,0 +1,189 @@ +package App::Yath::Command::speedtag; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::File::JSONL; + +use App::Yath::Options; + +use Cwd qw/getcwd/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/-log_file -max_short -max_medium/; +use Test2::Harness::Util qw/clean_path/; + +include_options( + 'App::Yath::Options::Debug', +); + +option_group {prefix => 'speedtag', category => 'speedtag options'} => sub { + option generate_durations_file => ( + type => 'd', + alt => ['durations', 'duration'], + description => "Write out a duration json file, if no path is provided 'duration.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/durations.json'], + + normalize => \&normalize_duration, + action => \&duration_action, + ); + + option pretty => ( + description => "Generate a pretty 'durations.json' file when combined with --generate-durations-file. (sorted and multilines)", + default => 0, + ); +}; + +sub group { 'log' } + +sub summary { "Tag tests with duration (short medium long) using a source log" } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] max_short_duration_seconds max_medium_duration_seconds" } + +sub description { + return <<" EOT"; +This command will read the test durations from a log and tag/retag all tests +from the log based on the max durations for each type. + EOT +} + +sub init { + my $self = shift; + + $self->{+MAX_SHORT} //= 15; + $self->{+MAX_MEDIUM} //= 30; +} + +sub normalize_duration { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub duration_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('durations.json'); +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + my $initial_dir = clean_path(getcwd()); + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + $self->{+MAX_SHORT} = shift @$args if @$args; + $self->{+MAX_MEDIUM} = shift @$args if @$args; + + die "max short duration must be an integer, got '$self->{+MAX_SHORT}'" unless $self->{+MAX_SHORT} && $self->{+MAX_SHORT} =~ m/^\d+$/; + die "max short duration must be an integer, got '$self->{+MAX_MEDIUM}'" unless $self->{+MAX_MEDIUM} && $self->{+MAX_MEDIUM} =~ m/^\d+$/; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my $durations_file = $self->settings->speedtag->generate_durations_file; + my %durations; + + while(1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + next unless $f->{harness_job_end}; + + my $job = {}; + $job->{file} = clean_path( $f->{harness_job_end}->{file} ) if $f->{harness_job_end} && $f->{harness_job_end}->{file}; + $job->{time} = $f->{harness_job_end}->{times}->{totals}->{total} if $f->{harness_job_end} && $f->{harness_job_end}->{times}; + + next unless $job->{file} && $job->{time}; + + my $dur; + if ($job->{time} < $self->{+MAX_SHORT}) { + $dur = 'short'; + } + elsif ($job->{time} < $self->{+MAX_MEDIUM}) { + $dur = 'medium'; + } + else { + $dur = 'long'; + } + + my $fh; + unless (open($fh, '<', $job->{file})) { + warn "Could not open file $job->{file} for reading\n"; + next; + } + + my @lines; + my $injected; + for my $line (<$fh>) { + if ($line =~ m/^(\s*)#(\s*)HARNESS-(CAT(EGORY)?|DUR(ATION))-(LONG|MEDIUM|SHORT)$/i) { + next if $injected++; + $line = "${1}#${2}HARNESS-DURATION-" . uc($dur) . "\n"; + } + push @lines => $line; + } + unless ($injected) { + my $new_line = "# HARNESS-DURATION-" . uc($dur) . "\n"; + my @header; + while (@lines && $lines[0] =~ m/^(#|use\s|package\s)/) { + push @header => shift @lines; + } + + unshift @lines => (@header, $new_line); + } + + close($fh); + unless (open($fh, '>', $job->{file})) { + warn "Could not open file $job->{file} for writing\n"; + next; + } + + print $fh @lines; + close($fh); + + if ( $durations_file ) { + my $tfile = $job->{file}; + $tfile =~ s{^\Q$initial_dir\E/+}{}; + $durations{ $tfile } = uc( $dur ); + } + + print "Tagged '$dur': $job->{file}\n"; + } + } + + if ( $durations_file ) { + my $jfile = Test2::Harness::Util::File::JSON->new(name => $durations_file, pretty => $self->settings->speedtag->pretty ); + $jfile->write( \%durations ); + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/start.pm b/libold2/App/Yath/Command/start.pm new file mode 100644 index 000000000..b74c4bb95 --- /dev/null +++ b/libold2/App/Yath/Command/start.pm @@ -0,0 +1,207 @@ +package App::Yath::Command::start; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util qw/mod2file open_file parse_exit clean_path/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use POSIX; +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Time::HiRes qw/sleep/; + +use Carp qw/croak/; +use File::Path qw/remove_tree/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Workspace', + 'App::Yath::Options::Persist', + 'App::Yath::Options::Collector', +); + +option_group {prefix => 'runner', category => "Persistent Runner Options"} => sub { + option reload => ( + short => 'r', + type => 'b', + description => "Attempt to reload modified modules in-place, restarting entire stages only when necessary.", + default => 0, + ); + + option restrict_reload => ( + type => 'D', + long_examples => ['', '=path'], + short_examples => ['', '=path'], + description => "Only reload modules under the specified path, if no path is specified look at anything under the .yath.rc path, or the current working directory.", + + normalize => sub { $_[0] eq '1' ? $_[0] : clean_path($_[0]) }, + action => \&restrict_action, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); +}; + +sub restrict_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + if ($norm eq '1') { + my $hset = $settings->harness; + my $path = $hset->config_file || $hset->cwd; + $path //= do { require Cwd; Cwd::getcwd() }; + $path =~ s{\.yath\.rc$}{}g; + push @{$$slot} => $path; + } + else { + push @{$$slot} => $norm; + } +} + +sub MAX_ATTACH() { 1_048_576 } + +sub group { 'persist' } + +sub always_keep_dir { 1 } + +sub summary { "Start the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command is used to start a persistant instance of yath. A persistant +instance is useful because it allows you to preload modules in advance, +reducing start time for any tests you decide to run as you work. + +A running instance will watch for changes to any preloaded files, and restart +itself if anything changes. Changed files are blacklisted for subsequent +reloads so that reloading is not a frequent occurence when editing the same +file over and over again. + EOT +} + +sub run { + my $self = shift; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my $pfile = find_pfile($settings, vivify => 1, no_checks => 1); + + if (-f $pfile) { + remove_tree($dir, {safe => 1, keep_root => 0}); + die "Persistent harness appears to be running, found $pfile\n"; + } + + my $all_state = Test2::Harness::State->new( + workdir => $dir, + settings => $settings, + ); + $all_state->transaction(w => sub { 1 }); + + $self->setup_plugins(); + $self->setup_resources(); + + my $stderr = File::Spec->catfile($dir, 'error.log'); + my $stdout = File::Spec->catfile($dir, 'output.log'); + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $pid = run_cmd( + stderr => $stderr, + stdout => $stdout, + + no_set_pgrp => !$settings->runner->daemon, + + command => [ + $^X, @prof, $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + monitor_preloads => 1, + persist => $pfile, + jobs_todo => 0, + ], + ); + + unless ($settings->runner->quiet) { + print "\nPersistent runner started!\n"; + + print "Runner PID: $pid\n"; + print "Runner dir: $dir\n"; + print "\nUse `yath watch` to monitor the persistent runner\n\n" if $settings->runner->daemon; + } + + Test2::Harness::Util::File::JSON->new(name => $pfile)->write({ + pid => $pid, + dir => $dir, + version => $VERSION, + user => $ENV{USER}, + hostname => hostname(), + }); + + return 0 if $settings->runner->daemon; + + $SIG{TERM} = sub { kill(TERM => $pid) }; + $SIG{INT} = sub { kill(INT => $pid) }; + + my $err_fh = open_file($stderr, '<'); + my $out_fh = open_file($stdout, '<'); + + while (1) { + my $out = waitpid($pid, WNOHANG); + my $wstat = $?; + + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + sleep(0.02) unless $out || $count; + + next if $out == 0; + return 255 if $out < 0; + + my $exit = parse_exit($?); + return $exit->{err} || $exit->{sig} || 0; + } +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/status.pm b/libold2/App/Yath/Command/status.pm new file mode 100644 index 000000000..2b1f0bd1b --- /dev/null +++ b/libold2/App/Yath/Command/status.pm @@ -0,0 +1,148 @@ +package App::Yath::Command::status; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Status info and process lists for the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will provide health details and a process list for the runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + print "\n**** Pending tests: ****\n"; + my $pending = $state->pending_tasks; + for my $run ($state->run, @{$state->pending_runs // []}) { + next unless $run; + my $run_id =$run->{run_id} or next; + + print "\nRun $run_id:\n"; + my $pending = $pending->{$run_id} // {}; + my @tasks; + my @check = ($pending); + while (my $it = shift @check) { + my $ref = ref($it); + + if ($ref eq 'ARRAY') { + push @check => @$it; + next; + } + + if ($ref eq 'HASH') { + if ($it->{job_id}) { + push @tasks => $it; + next; + } + + push @check => values %$it; + next; + } + } + + if (!@tasks) { + print "--No pending tasks for this run--\n"; + next; + } + + my @rows = map {[$_->{job_id}, $_->{is_try} // $_->{job_try} // 0, $_->{rel_file}, join(', ' => @{$_->{conflicts} // []})]} @tasks; + my $run_table = Term::Table->new( + collapse => 1, + header => [qw/uuid try test conflicts/], + rows => [ sort { $a->[2] cmp $b->[2] } @rows ], + ); + + print "$_\n" for $run_table->render; + } + + print "\n**** Runner Stages: ****\n"; + my $stage_status = $state->stage_readiness // {}; + my $reload_status = $state->reload_state // {}; + my $reload_issues = 0; + + my $rows = []; + for my $stage (keys %$stage_status) { + my $pid = $stage_status->{$stage} ||= ''; + my $ready = $pid ? 'YES' : 'NO'; + $pid = 'N/A' if $pid && $pid == 1; + + my $issues = keys %{$reload_status->{$stage}}; + my $reload = $issues ? 'YES' : 'NO'; + $reload_issues += $issues; + + push @$rows => [$pid, $stage, $ready, $reload]; + } + + @$rows = sort { $a->[0] <=> $b->[0] } @$rows; + + my $stage_table = Term::Table->new( + collapse => 1, + header => [qw/pid stage ready/, 'reload issues'], + rows => $rows, + ); + print "$_\n" for $stage_table->render; + + if ($reload_issues) { + my %seen; + print "\n**** Reload issues: ****\n"; + for my $stage (sort keys %$reload_status) { + for my $file (keys %{$reload_status->{$stage}}) { + next if $seen{$file}++; + my $data = $reload_status->{$stage}->{$file} or next; + print "\n==== SOURCE FILE: $file ====\n"; + print $data->{error} if $data->{error}; + print $_ for @{$data->{warnings} // []}; + } + } + print "\n"; + } + + print "\n**** Running tests: ****\n"; + my $running = $state->running_tasks; + my $running_tasks = [values %$running]; + my @rows = map {[$self->get_job_pid($_->{run_id}, $_->{job_id}) // 'N/A', $_->{job_id}, $_->{is_try} // $_->{job_try} // 0, $_->{rel_file}, join(', ' => @{$_->{conflicts} // []})]} @$running_tasks; + if (@rows) { + my $run_table = Term::Table->new( + collapse => 1, + header => [qw/pid uuid try test conflicts/], + rows => [ sort { $a->[0] <=> $b->[0] } @rows ], + ); + print "$_\n" for $run_table->render; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/stop.pm b/libold2/App/Yath/Command/stop.pm new file mode 100644 index 000000000..4cb488e5f --- /dev/null +++ b/libold2/App/Yath/Command/stop.pm @@ -0,0 +1,56 @@ +package App::Yath::Command::stop; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; + +use File::Spec(); + +use Test2::Harness::Util::File::JSON(); + +use Test2::Harness::Util qw/open_file/; +use App::Yath::Util qw/find_pfile/; +use File::Path qw/remove_tree/; + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Stop the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will stop a persistent instance, and output any log contents. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + $self->App::Yath::Command::test::terminate_queue(); + + $_->teardown($self->settings) for @{$self->settings->harness->plugins}; + + sleep(0.02) while kill(0, $self->pfile_data->{pid}); + + my $pfile = $self->pfile; + unlink($pfile) if -f $pfile; + + remove_tree($self->workdir, {safe => 1, keep_root => 0}) if -d $self->workdir; + + print "\n\nRunner stopped\n\n" unless $self->settings->display->quiet; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/test.pm b/libold2/App/Yath/Command/test.pm new file mode 100644 index 000000000..fa88aaa29 --- /dev/null +++ b/libold2/App/Yath/Command/test.pm @@ -0,0 +1,935 @@ +package App::Yath::Command::test; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Event; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Runner::State; + +use Test2::Harness::Util::JSON qw/encode_json decode_json JSON/; +use Test2::Harness::Util qw/mod2file open_file chmod_tmp/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + +use File::Spec; +use Fcntl(); + +use Time::HiRes qw/sleep time/; +use List::Util qw/sum max min/; +use Carp qw/croak/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/ + <runner_pid +ipc +signal + + +run <run_id + + +auditor_reader + +collector_writer + +renderer_reader + +auditor_writer + + +renderers + +logger + +last_log + + +tests_seen + +asserts_seen + + +state +all_state + + <cleanup_subs + + <final_data +/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Finder', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Run', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Workspace', + 'App::Yath::Options::Collector', +); + +sub MAX_ATTACH() { 1_048_576 } + +sub group { ' test' } + +sub summary { "Run tests" } +sub cli_args { '[--] [test files/dirs] [::] [arguments to test scripts] [test_file.t] [test_file2.t="--arg1 --arg2 --param=\'foo bar\'"] [:: --argv-for-all-tests]' } + +sub description { + return <<" EOT"; +This yath command (which is also the default command) will run all the test +files for the current project. If no test files are specified this command will +look for the 't', and 't2' directories, as well as the 'test.pl' file. + +This command is always recursive when given directories. + +This command will add 'lib', 'blib/arch' and 'blib/lib' to the perl path for +you by default (after any -I's). You can specify -l if you just want lib, -b if +you just want the blib paths. If you specify both -l and -b both will be added +in the order you specify (order relative to any -I options will also be +preserved. If you do not specify they will be added in this order: -I's, lib, +blib/lib, blib/arch. You can also add --no-lib and --no-blib to avoid both. + +Any command line argument that is not an option will be treated as a test file +or directory of test files to be run. + +If you wish to specify the ARGV for tests you may append them after '::'. This +is mainly useful for Test::Class::Moose and similar tools. EVERY test run will +get the same ARGV. + EOT +} + +sub spawn_args { + my $self = shift; + my ($settings) = @_; + + my @out; + + if ($ENV{T2_DEVEL_COVER} && $ENV{T2_COVER_SELF}) { + push @out => '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + } + + my $plugins = $settings->harness->plugins; + if (@$plugins) { + push @out => $_->spawn_args($settings) for grep { $_->can('spawn_args') } @$plugins; + } + + return @out; +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; + + $self->{+CLEANUP_SUBS} = []; +} + +sub _resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh) = @_; + + # 1mb if we can + my $size = 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub auditor_reader { + my $self = shift; + return $self->{+AUDITOR_READER} if $self->{+AUDITOR_READER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+AUDITOR_READER}; +} + +sub collector_writer { + my $self = shift; + return $self->{+COLLECTOR_WRITER} if $self->{+COLLECTOR_WRITER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+COLLECTOR_WRITER}; +} + +sub renderer_reader { + my $self = shift; + return $self->{+RENDERER_READER} if $self->{+RENDERER_READER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+RENDERER_READER}; +} + +sub auditor_writer { + my $self = shift; + return $self->{+AUDITOR_WRITER} if $self->{+AUDITOR_WRITER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+AUDITOR_WRITER}; +} + +sub workdir { + my $self = shift; + $self->settings->workspace->workdir; +} + +sub ipc { + my $self = shift; + return $self->{+IPC} //= Test2::Harness::IPC->new( + handlers => { + INT => sub { $self->handle_sig(@_) }, + TERM => sub { $self->handle_sig(@_) }, + } + ); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + eval { $_->signal($sig) } for grep { $_->can('signal') } @{$self->renderers}; + + print STDERR "\nCaught SIG$sig, forwarding signal to child processes...\n"; + $self->ipc->killall($sig); + + if ($self->{+SIGNAL}) { + print STDERR "\nSecond signal ($self->{+SIGNAL} followed by $sig), exiting now without waiting\n"; + exit 1; + } + + $self->{+SIGNAL} = $sig; +} + +sub monitor_preloads { 0 } + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $plugins = $self->settings->harness->plugins; + + if ($self->start()) { + $self->render(); + $self->stop(); + + my $final_data = $self->{+FINAL_DATA} or die "Final data never received from auditor!\n"; + my $pass = $self->{+TESTS_SEEN} && $final_data->{pass}; + $self->render_final_data($final_data); + $self->produce_summary($pass); + + if (@$plugins) { + my %args = ( + settings => $settings, + final_data => $final_data, + pass => $pass ? 1 : 0, + tests_seen => $self->{+TESTS_SEEN} // 0, + asserts_seen => $self->{+ASSERTS_SEEN} // 0, + ); + $_->finish(%args) for @$plugins; + } + + return $pass ? 0 : 1; + } + + $self->stop(); + + return 1; +} + +sub DESTROY { + my $self = shift; + + local ($?, $!, $@, $_); + + my $cleanup = delete $self->{+CLEANUP_SUBS} or return; + for my $sub (@$cleanup) { + eval { $sub->(); 1 } or warn $@; + } +} + +sub write_test_info { + my $self = shift; + + return if $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO}; + + my $info_file = "./.test_info.$$.json"; + + my $workdir = $self->workdir; + Test2::Harness::Util::File::JSON->new(name => $info_file)->write({ + workdir => $self->workdir, + job_count => $self->job_count, + }); + + push @{$self->{+CLEANUP_SUBS}} => sub { + return unless -e $info_file; + return unless Test2::Harness::Util::File::JSON->new(name => $info_file)->read->{workdir} eq $workdir; + unlink($info_file) or die "Could not unlink info file: $!"; + }; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} = 1; +} + +sub start { + my $self = shift; + + $self->all_state->transaction(w => sub { 1 }); + + $self->ipc->start(); + $self->parse_args; + + $self->write_test_info(); + my $pop = $self->populate_queue(); + $self->terminate_queue(); + + return unless $pop; + + $self->setup_plugins(); + $self->setup_resources(); + + $self->start_runner(jobs_todo => $pop); + $self->start_collector(); + $self->start_auditor(); + + return 1; +} + +sub render { + my $self = shift; + + my $ipc = $self->ipc; + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + my $plugins = $self->settings->harness->plugins; + + my $handle_plugins = [grep { $_->can('handle_event') } @$plugins]; + my $annotate_plugins = [grep { $_->can('annotate_event') } @$plugins]; + + # render results from log + my $reader = $self->renderer_reader(); + $reader->blocking(0); + my $buffer; + while (1) { + return if $self->{+SIGNAL}; + $_->step for @{$renderers}; + + my $line = <$reader>; + unless(defined $line) { + $ipc->wait() if $ipc; + sleep 0.02; + next; + } + + if ($buffer) { + $line = $buffer . $line; + $buffer = undef; + } + + unless (substr($line, -1, 1) eq "\n") { + $buffer //= ""; + $buffer .= $line; + next; + } + + my $e = decode_json($line); + + if (defined $e) { + bless($e, 'Test2::Harness::Event'); + my $fd = $e->{facet_data} //= {}; + + my $changed = 0; + for my $p (@$annotate_plugins) { + my %inject = $p->annotate_event($e, $settings); + next unless keys %inject; + $changed++; + + # Can add new facets, but not modify existing ones. + # Someone could force the issue by modifying the event directly + # inside 'annotate_event', this is not supported, but also not + # forbidden, user beware. + for my $f (keys %inject) { + if (exists $fd->{$f}) { + if ('ARRAY' eq ref($fd->{$f})) { + push @{$fd->{$f}} => @{$inject{$f}}; + } + else { + warn "Plugin '$p' tried to add facet '$f' via 'annotate_event()', but it is already present and not a list, ignoring plugin annotation.\n"; + } + } + else { + $fd->{$f} = $inject{$f}; + } + } + + } + + if ($logger) { + if ($changed) { + my $newline = $e->as_json; + print $logger $newline, "\n"; + } + else { + print $logger $line; + } + } + } + else { + last; + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + $_->render_event($e) for @$renderers; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + $_->handle_event($e, $settings) for @$handle_plugins; + + $ipc->wait() if $ipc; + } +} + +sub get_job_pid { + my $self = shift; + my ($run_id, $job_id) = @_; + + return undef unless $run_id && $job_id; + + my $jdata = $self->{+ALL_STATE}->data->jobs->{$self->{+RUN_ID}} or return undef; + my $list = $jdata->{list} or return undef; + + my $found; + for my $task (@$list) { + next unless $task->{job_id} && $task->{job_id} eq $job_id; + $found = $task; + # Do not end loop early, we want the last matching entry in cases of re-run + } + + return undef unless $found; + + return $found->{pid} // undef; +} + +sub stop { + my $self = shift; + + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + + $self->teardown_plugins($renderers, $logger); + if ($logger) { + print $logger "null\n"; + close($logger); + } + + $_->finish() for @$renderers; + + my $ipc = $self->ipc; + print STDERR "Waiting for child processes to exit...\n" if $self->{+SIGNAL}; + + if ($self->{+SIGNAL}) { + my $state = $self->state; + delete $state->{no_poll}; + $state->poll; + my $running = $state->running_tasks; + $state->halt_run($self->{+RUN_ID}); + + for my $task (values %$running) { + next unless $task->{run_id} && $task->{run_id} eq $self->{+RUN_ID}; + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + } + + $ipc->wait(all => 1); + $ipc->stop; + + unless ($settings->display->quiet > 2) { + printf STDERR "\nNo tests were seen!\n" unless $self->{+TESTS_SEEN}; + + printf("\nKeeping work dir: %s\n", $self->workdir) + if $settings->debug->keep_dirs; + + if ($settings->logging->log) { + print "\n"; + print "Wrote log file: " . $settings->logging->log_file . "\n"; + print " (Symlinked to: " . $self->{+LAST_LOG} . ")\n"; + } + + $self->finalize_plugins(); + } +} + +sub terminate_queue { + my $self = shift; + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + $queue->{$_}->{closed} = 1 for keys %$queue; + }); + + $self->state->end_queue(); +} + +sub build_run { + my $self = shift; + + return $self->{+RUN} if $self->{+RUN}; + + my $settings = $self->settings; + my $dir = $self->workdir; + + my $run = $settings->build(run => 'Test2::Harness::Run'); + + mkdir($run->run_dir($dir)) or die "Could not make run dir: $!"; + chmod_tmp($dir); + + return $self->{+RUN} = $run; +} + +sub all_state { + my $self = shift; + + $self->{+ALL_STATE} //= Test2::Harness::State->new( + workdir => $self->workdir, + job_count => $self->job_count, + settings => $self->settings, + ); +} + +sub state { + my $self = shift; + + my $all_state = $self->all_state; + + $self->{+STATE} //= Test2::Harness::Runner::State->new( + state => $all_state, + workdir => $self->workdir, + job_count => $self->job_count, + no_poll => 1, + ); +} + +sub job_count { + my $self = shift; + + return $self->settings->runner->job_count; +} + +sub finder_args {()} + +sub populate_queue { + my $self = shift; + + my $run = $self->build_run(); + $self->{+RUN_ID} = $run->run_id; + my $settings = $self->settings; + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + + my $state = $self->state; + my $plugins = $settings->harness->plugins; + + $state->queue_run($run->queue_item($plugins)); + + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my @add_to_queue; + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + $state->queue_task($task); + + push @add_to_queue => $task; + } + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + push @{$queue->{$self->{+RUN_ID}}->{list} //= []} => @add_to_queue; + }); + + $state->stop_run($run->run_id); + + return $job_count; +} + +sub produce_summary { + my $self = shift; + my ($pass) = @_; + + my $settings = $self->settings; + + my $time_data = { + start => $settings->harness->start, + stop => time(), + }; + + $time_data->{wall} = $time_data->{stop} - $time_data->{start}; + + my @times = times(); + @{$time_data}{qw/user system cuser csystem/} = @times; + $time_data->{cpu} = sum @times; + + my $cpu_usage = int($time_data->{cpu} / $time_data->{wall} * 100); + + $self->write_summary($pass, $time_data, $cpu_usage); + $self->render_summary($pass, $time_data, $cpu_usage); +} + +sub write_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + my $file = $self->settings->debug->summary or return; + + my $final_data = $self->{+FINAL_DATA}; + + my $failures = @{$final_data->{failed} // []}; + + my %data = ( + %$final_data, + + pass => $pass ? JSON->true : JSON->false, + + total_failures => $failures // 0, + total_tests => $self->{+TESTS_SEEN} // 0, + total_asserts => $self->{+ASSERTS_SEEN} // 0, + + cpu_usage => $cpu_usage, + + times => $time_data, + ); + + require Test2::Harness::Util::File::JSON; + my $jfile = Test2::Harness::Util::File::JSON->new(name => $file); + $jfile->write(\%data); + + print "\nWrote summary file: $file\n\n"; + + return; +} + +sub render_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + return if $self->settings->display->quiet > 1; + + my $final_data = $self->{+FINAL_DATA}; + my $failures = @{$final_data->{failed} // []}; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $self->{+TESTS_SEEN}", + "Assertion Count: $self->{+ASSERTS_SEEN}", + $time_data ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->settings->display->color && USE_ANSI_COLOR) { + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + +sub render_final_data { + my $self = shift; + my ($final_data) = @_; + + return if $self->settings->display->quiet > 1; + + if (my $rows = $final_data->{retried}) { + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + header => ['Job ID', 'Times Run', 'Test File', "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{failed}) { + print "\nThe following jobs failed:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Test File', 'Subtests'], + rows => [map { my $r = [@{$_}]; $r->[2] = stringify_subtest_map($r->[2]) if $r->[2]; $r} @$rows], + ); + print "\n"; + } + + if (my $rows = $final_data->{halted}) { + print "\nThe following jobs requested all testing be halted:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File', "Reason"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{unseen}) { + print "\nThe following jobs never ran:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File'], + rows => $rows, + ); + print "\n"; + } +} + +sub stringify_subtest_map { + my ($map) = @_; + + my $out = ""; + my @todo = @$map; + my @state; + while (my $st = shift @todo) { + if (!ref($st)) { + pop @state if $st eq 'pop'; + next; + } + push @state => $st->[0]; + $out .= join(' -> ' => @state) . "\n"; + unshift @todo => (@{$st->[1]}, 'pop'); + } + + return $out; +} + +sub logger { + my $self = shift; + + return $self->{+LOGGER} if $self->{+LOGGER}; + + my $settings = $self->{+SETTINGS}; + + return unless $settings->logging->log; + + my $file = $settings->logging->log_file; + + if ($settings->logging->bzip2) { + no warnings 'once'; + require IO::Compress::Bzip2; + $self->{+LOGGER} = IO::Compress::Bzip2->new($file) or die "Could not open log file '$file': $IO::Compress::Bzip2::Bzip2Error"; + } + elsif ($settings->logging->gzip) { + no warnings 'once'; + require IO::Compress::Gzip; + $self->{+LOGGER} = IO::Compress::Gzip->new($file) or die "Could not open log file '$file': $IO::Compress::Gzip::GzipError"; + } + else { + $self->{+LOGGER} = open_file($file, '>'); + } + + for my $ext ('jsonl', 'jsonl.bz2', 'jsonl.gz') { + my $name = "./lastlog.$ext"; + next unless -f $name; + local ($!, $@) = (0, ''); + eval { unlink($name) } or warn "Could not unlink '$name': ($!) $@"; + } + + if ($file =~ m/\.(jsonl(?:\.(?:bz2|gz))?)$/) { + my $ext = $1; + my $name = "./lastlog.$ext"; + if (eval { symlink($file, $name); 1 }) { + $self->{+LAST_LOG} = $name; + } + else { + warn "Could not symlink the log file to '$name': $@"; + } + } + + return $self->{+LOGGER}; +} + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + my @renderers; + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub start_auditor { + my $self = shift; + + my $run = $self->build_run(); + my $settings = $self->settings; + + my $ipc = $self->ipc; + $ipc->spawn( + stdin => $self->auditor_reader(), + stdout => $self->auditor_writer(), + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + auditor => 'Test2::Harness::Auditor', + $run->run_id, + procname_prefix => $settings->debug->procname_prefix, + ], + ); + + close($self->auditor_writer()); +} + +sub collector_options { () } + +sub start_collector { + my $self = shift; + + my $dir = $self->workdir; + my $run = $self->build_run(); + my $settings = $self->settings; + my $runner_pid = $self->runner_pid; + + my ($rh, $wh); + pipe($rh, $wh) or die "Could not create pipe"; + + my %options = (show_runner_output => 1); + if ($settings->check_prefix('display')) { + $options{show_runner_output} = $settings->display->hide_runner_output ? 0 : 1; + $options{truncate_runner_output} = $settings->display->truncate_runner_output; + } + + %options = ( + %options, + $self->collector_options(), + ); + + my $ipc = $self->ipc; + $ipc->spawn( + stdout => $self->collector_writer, + stdin => $rh, + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + collector => 'Test2::Harness::Collector', + $dir, $run->run_id, $runner_pid, + %options, + ], + ); + + close($rh); + print $wh encode_json($run) . "\n"; + close($wh); + + close($self->collector_writer()); +} + +sub start_runner { + my $self = shift; + my %args = @_; + + $args{monitor_preloads} //= $self->monitor_preloads; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $ipc = $self->ipc; + my $proc = $ipc->spawn( + stderr => File::Spec->catfile($dir, 'error.log'), + stdout => File::Spec->catfile($dir, 'output.log'), + env_vars => { @prof ? (NYTPROF => 'start=no:addpid=1') : () }, + no_set_pgrp => 1, + command => [ + $^X, @prof, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + %args, + ], + ); + + $self->{+RUNNER_PID} = $proc->pid; + + return $proc; +} + +sub parse_args { + my $self = shift; + my $settings = $self->settings; + my $args = $self->args; + + my $dest = $settings->finder->search; + for my $arg (@$args) { + next if $arg eq '--'; + if ($arg eq '::') { + $dest = $settings->run->test_args; + next; + } + + push @$dest => $arg; + } + + return; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/times.pm b/libold2/App/Yath/Command/times.pm new file mode 100644 index 000000000..c5e2538f0 --- /dev/null +++ b/libold2/App/Yath/Command/times.pm @@ -0,0 +1,150 @@ +package App::Yath::Command::times; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Times qw/render_duration/; + +use Test2::Harness::Util::File::JSONL; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/-log_file <fields/; + +include_options( + 'App::Yath::Options::Debug', +); + +sub summary { "Get times from a test log" } + +sub group { 'log' } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [Field1] [Field2]" } + +sub description { + return <<" EOT"; +This command will consume the log of a previous run, and output all timing data +from shortest test to longest. You can specify a sort order by listing fields +in your desired order after the log file on the command line. + EOT +} + +my @NUMERIC = qw/total startup events cleanup/; +my %NUMERIC = map { $_ => 1 } @NUMERIC; + +my @ALPHA = qw/file/; +my %ALPHA = map { $_ => 1 } @ALPHA; + +my @FIELDS = (@NUMERIC, @ALPHA); +my %FIELDS = map { $_ => 1 } @FIELDS; + +sub run { + my $self = shift; + + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my %seen; + my @fields; + for my $field (@$args, @FIELDS) { + $field = lc($field); + next if $seen{$field}++; + die "'$field' is not a valid field\n" unless $FIELDS{$field}; + push @fields => $field; + } + + $self->{+FIELDS} = \@fields; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my @jobs; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + next unless $f->{harness_job_end}; + + my $job = {}; + $job->{file} = $f->{harness_job_end}->{rel_file} if $f->{harness_job_end} && $f->{harness_job_end}->{rel_file}; + $job->{time} = $f->{harness_job_end}->{times}->{totals} if $f->{harness_job_end} && $f->{harness_job_end}->{times}; + + push @jobs => $job; + } + } + + my @rows; + my $totals = {file => 'TOTAL'}; + + @jobs = sort { $self->sort_compare($a, $b) } @jobs; + + for my $job (@jobs) { + my $data = $job->{time}; + push @rows => $self->build_row({%$data, file => $job->{file}}); + $totals->{$_} += $data->{$_} for @NUMERIC; + } + + push @rows => [map { '--' } @fields]; + push @rows => $self->build_row($totals); + + require Term::Table; + my $table = Term::Table->new( + header => [map { ucfirst($_) } @fields], + rows => \@rows, + ); + + print "$_\n" for $table->render; + + return 0; +} + +sub build_row { + my $self = shift; + my ($data) = @_; + + return [map { $NUMERIC{$_} && defined($data->{$_}) ? render_duration($data->{$_}) : $data->{$_} } @{$self->{+FIELDS}}]; +} + +sub sort_compare { + my $self = shift; + my ($ja, $jb) = @_; + + my $order = $self->{+FIELDS}; + + my $ta = $ja->{time}; + my $tb = $jb->{time}; + + for my $field (@$order) { + my $fa = $ta->{$field}; + my $fb = $tb->{$field}; + + my $da = defined $fa; + my $db = defined $fb; + + next unless $da || $db; + return 1 if $da && !$db; + return -1 if $db && !$da; + + my $delta = $ALPHA{$field} ? lc($fa) cmp lc($fb) : $fa <=> $fb; + return $delta if $delta; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/watch.pm b/libold2/App/Yath/Command/watch.pm new file mode 100644 index 000000000..edd935c63 --- /dev/null +++ b/libold2/App/Yath/Command/watch.pm @@ -0,0 +1,100 @@ +package App::Yath::Command::watch; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; + +use Test2::Harness::Util::File::JSON; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Monitor the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will tail the logs from a persistent instance of yath. STDOUT and +STDERR will be printed as seen, so may not be in proper order. + EOT +} + +sub run { + my $self = shift; + + my $args = $self->args; + shift @$args if @$args && $args->[0] eq '--'; + my $stop = 1 if @$args && $args->[0] eq 'STOP'; + + my $pfile = find_pfile($self->settings, no_fatal => 1) + or die "No persistent harness was found for the current path.\n"; + + print "\nFound: $pfile\n"; + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + print "\n"; + + my $err_f = File::Spec->catfile($data->{dir}, 'error.log'); + my $out_f = File::Spec->catfile($data->{dir}, 'output.log'); + + my $err_fh = open_file($err_f, '<'); + my $out_fh = open_file($out_f, '<'); + + my $auxdir = File::Spec->catdir($data->{dir}, 'aux_logs'); + my %aux; + + while (1) { + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + if (-d $auxdir) { + opendir(my $dh, $auxdir) or die "Could not open auxdir: $!"; + for my $file (readdir($dh)) { + next if $aux{$file}; + next unless $file =~ m/\.log$/; + my $full = File::Spec->catfile($auxdir, $file); + next unless -f $full; + $aux{$file} = open_file($full, '<'); + $count++; + } + } + + for my $file (sort keys %aux) { + my $fh = $aux{$file}; + my $ofh = $file =~ m/STDERR/ ? \*STDERR : \*STDOUT; + while (my $line = <$fh>) { + print $ofh $line; + } + } + + next if $count; + last if $stop; + last unless -f $pfile; + sleep 0.02; + } + + return 0; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Command/which.pm b/libold2/App/Yath/Command/which.pm new file mode 100644 index 000000000..53c94eb8b --- /dev/null +++ b/libold2/App/Yath/Command/which.pm @@ -0,0 +1,49 @@ +package App::Yath::Command::which; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Util::File::JSON; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Locate the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This will tell you about any persistent runners it can find. + EOT +} + +sub run { + my $self = shift; + + my $pfile = find_pfile($self->settings, no_fatal => 1); + + unless ($pfile) { + print "\nNo persistent harness was found for the current path.\n\n"; + return 0; + } + + print "\nFound: $pfile\n"; + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + print "\n"; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/libold2/App/Yath/Converting.pm b/libold2/App/Yath/Converting.pm new file mode 100644 index 000000000..a0dce16f5 --- /dev/null +++ b/libold2/App/Yath/Converting.pm @@ -0,0 +1,105 @@ +package App::Yath::Converting; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Converting - Things you may need to change in your tests before you can use yath. + +=head1 NON-TAP FORMATTER + +By default yath tells any L<Test2> or L<Test::Builder> tests to use +L<Test2::Formatter::Stream> instead of L<Test2::Formatter::TAP>. This is done +in order to make sure as much data as possible makes it to yath, TAP is a lossy +formater by comparison. + +This is not normally a problem, but tests that do strange things with +STDERR/STDOUT, or try to intercept output from the regular TAP formatter can +have issues with this. + +=head2 SOLUTIONS + +=head3 HARNESS-NO-STREAM + +You can add a harness directive to the top of offending tests that tell the +harness those specific tests should still use the TAP formatter. + + #!/usr/bin/perl + # HARNESS-NO-STREAM + ... + +This directive can come after the C<#!> line, and after use statements, but +must come BEFORE any empty lines or runtime statements. + +=head3 --no-stream + +You can run yath with the C<--no-stream> option, which will have tests default +to TAP. This is not recommended as TAP is lossy. + +=head1 TESTS ARE RUN VIA FORK BY DEFAULT + +The default mode for yath is to preload a few things, then fork to spawn each +test. This is a complicated procedure, and it uses L<goto::file> under the +hood. Sometimes you have tests that simply will not work this way, or tests +that verify specific libraries are not already loaded. + +=head2 SOLUTIONS + +=head3 HARNESS-NO-PRELOAD + +You can use this harness directive inside your tests to tell yath not to fork, +but to instead launch a new perl process to run the test. + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + ... + +=head3 --no-fork + +=head3 --no-preload + +Both these options tell yath not to preload+fork, but to run ALL tests in new +processes. This is slow, it is better to mark specific tests that have issues +in preload mode. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Instance.pm b/libold2/App/Yath/Instance.pm new file mode 100644 index 000000000..1dd5e349a --- /dev/null +++ b/libold2/App/Yath/Instance.pm @@ -0,0 +1,389 @@ +package App::Yath::Instance; +use strict; +use warnings; + +use File::Spec; + +use Test2::Harness::State; +use Test2::Harness::Settings; +use Test2::Harness::Aggregator; + +use Carp qw/croak confess/; +use Test2::Harness::Util qw/clean_path/; +use Test2::Harness::Util::IPC qw/pid_is_running/; + +use Test2::Util::HashBase qw{ + +workdir + +state_file + +state + + +runners + +renderers + +aggregators + +collectors + + +procwatcher + +scheduler + +console + + <observer +}; + +sub connect { + my $class = shift; + my (%params) = @_; + + my $workdir = $params{+WORKDIR}; + my $state_file = $params{+STATE_FILE}; + my $state = $params{+STATE}; + + my $self = bless(\%params, $class); + + croak "You must specify either a 'state', 'workdir' or a 'state_file'" + unless $workdir || $state_file || $state; + + $state_file = $self->{+STATE_FILE} //= clean_path( + $state ? $state->state_file : File::Spec->catfile($workdir, 'state.json'), + ); + + $state = $self->{+STATE} //= Test2::Harness::State->new( + state_file => $state_file, + workdir => $workdir, + ); + + $workdir //= $state->workdir; + + croak "Invalid state" unless $state; + croak "Invalid work dir '$workdir'" unless -d $workdir; + croak "Invalid state file '$state_file'" unless -e $state_file; + croak "Unable to fetch settings from state" unless $self->settings; + + return $self; +} + +sub create { + my $class = shift; + my ($settings) = @_; + + my $workdir = $settings->workspace->workdir; + croak "Invalid work dir '$workdir'" unless -d $workdir; + + my $state_file = File::Spec->catfile($workdir, 'state.json'); + my $state = Test2::Harness::State->new( + workdir => $workdir, + state_file => $state_file, + ); + + $state->init_state(settings => $settings); + + return bless( + { + workdir => $workdir, + state_file => $state_file, + state => $state, + }, + $class, + ); +} + +sub settings { + my $self = shift; + + $self->state->transaction(r => sub { + my $data = $_[1]->settings or return; + return Test2::Harness::Settings->new(%$data); + }); +} + +sub run_dir { + my $self = shift; + my ($run_id) = @_; + return File::Spec->catdir($self->workdir, $run_id); +} + +sub start_aggregator { + my $self = shift; + my ($run_id, $name, %params) = @_; + + croak "Cannot start an aggregator from an observer" if $self->{+OBSERVER}; + + croak "There is already an aggregator named '$name' for run id '$run_id'" + if $self->check_aggregator($run_id, $name); + + my $state = $self->state; + my $rundir = $self->rundir; + + my $output_file = File::Spec->catfile($rundir, "$name.json"); + my $fifo_file = File::Spec->catfile($rundir, "$name.fifo"); + + my $aggregator = Test2::Harness::Aggregator->new( + name => $name, + state => $state, + run_id => $run_id, + fifo_file => $fifo_file, + output_file => $output_file, + ); + + my ($pid, $ppid); + + my $run_aggregator = sub { + my $res; + eval { $res = $aggregator->run($ppid) } or warn $@; + exit($res // 255); + }; + + my $add_aggregator = sub { + my $entry = { + pid => $pid, + name => $name, + fifo => $fifo_file, + run_id => $run_id, + parent => $ppid, + output => $output_file, + }; + + my $pid_entry = { + pid => $pid, + name => $name, + type => 'aggregator', + parent => $ppid, + run_id => $run_id, + }; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + $data->aggregators->{$run_id}->{$name} = $entry; + $data->processes->{$pid} = $pid_entry; + $data->processes->{$ppid}->{children}->{$pid} = $pid; + } + ); + + return $entry; + }; + + if ($ppid = $params{ppid} || $params{parent_pid}) { + $pid = $$; + eval { + $add_aggregator->(); + $run_aggregator->(); + 1; + } or warn $@; + exit(255); + } + + $ppid = $$; + $pid = fork // die "Could not fork: $!"; + + # Parent: + return $add_aggregator->() if $pid; + + $run_aggregator->(); +} + +sub aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + my $pid = $self->check_aggregator($run_id, $name); + return $pid if $pid; + croak "No aggregator named '$name' for run id '$run_id'"; +} + +sub aggregators { + my $self = shift; + + my @out; + + $self->{+STATE}->transaction(r => sub { + my ($state, $data) = @_; + @out = values %{$data->aggregators // {}}; + }); + + return grep { $self->_check_aggregator($_) } @out; +} + +sub check_aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + my $entry; + $self->{+STATE}->transaction(r => sub { + my ($state, $data) = @_; + $entry = $data->aggregators->{$run_id}->{$name}; + }); + + return undef unless $entry; + + return $self->_check_aggregator($entry); +} + +sub _check_aggregator { + my $self = shift; + my ($entry) = @_; + + my $have_fifo = -p $entry->{fifo}; + my $have_proc = pid_is_running($entry->{pid}); + + return $entry if $have_fifo && $have_proc; + return undef if $have_proc; + + # Do not modify state from an observer + return undef if $self->{+OBSERVER}; + + # No proc means we need to clear it. We may or may not have a fifo to clean + # up. If we have a proc and no fifo though it could be that the proc is + # still starting. + + my $pid = $entry->{pid}; + my $name = $entry->{name}; + my $fifo = $entry->{fifo}; + my $run_id = $entry->{run_id}; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + delete $data->aggregators->{$run_id}->{$name}; + + my $pentry = delete $data->processes->{$pid}; + + delete $data->processes->{$pentry->{parent}}->{children}->{$pid} + if $pentry->{parent}; + + return unless -e $fifo; + unlink($fifo) or warn "Failed to delete fifo '$fifo': $!"; + }, + ); + + return undef; +} + +sub stop_aggregator { + my $self = shift; + my ($run_id, $name) = @_; + + croak "Cannot stop an aggregator from an observer" if $self->{+OBSERVER}; + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + return if $data->aggregators->{$run_id}->{$name}->{stopped}; + $data->aggregators->{$run_id}->{$name}->{stopped} = 1; + + $fifo = Atomic::Pipe->write_fifo($entry->{fifo}); + $fifo->write_message("TERMINATE"); + $fifo->close(); + }, + ); + + return; +} + +sub kill_aggregator { + my $self = shift; + my ($run_id, $name, $sig) = @_; + + croak "Cannot kill an aggregator from an observer" if $self->{+OBSERVER}; + + my ($entry, $out); + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + + $entry = $data->aggregators->{$run_id}->{$name}; + return undef unless $entry; + + $out = kill($sig, $entry->{pid}); + }, + ); + + return $out if $entry; + croak "Invalid aggregator ($run_id, $name)"; +} + +sub start_collector { } +sub stop_collector { } +sub kill_collector { } +sub check_collector { } +sub collector { } + +sub kill { } + +sub start_runner { } +sub stop_runner { } +sub reload_runner { } +sub kill_runner { } +sub check_runner { } +sub runner { } + +sub start_renderer { } +sub stop_renderer { } +sub kill_renderer { } +sub check_renderer { } +sub renderer { } + +sub start_procwatcher { } +sub stop_procwatcher { } +sub kill_procwatcher { } +sub check_procwatcher { } +sub procwatcher { } + +sub start_scheduler { } +sub stop_scheduler { } +sub kill_scheduler { } +sub check_scheduler { } +sub scheduler { } + +sub start_console { } +sub stop_console { } +sub kill_console { } +sub check_console { } +sub console { } + + +1; + +__END__ +sub init { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + elsif($settings) { + + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + + + $self->SUPER::init(); +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[1]->settings}) }); +} + + + +1; diff --git a/libold2/App/Yath/Option.pm b/libold2/App/Yath/Option.pm new file mode 100644 index 000000000..5cfac4cba --- /dev/null +++ b/libold2/App/Yath/Option.pm @@ -0,0 +1,1157 @@ +package App::Yath::Option; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use Test2::Harness::Util::HashBase qw{ + <title + <field <name <type <trace + <ignore_for_build + + <prefix <short <alt + + <pre_command <from_plugin <from_command + + <pre_process + <adds_options + + <default <normalize <action <negate <autofill + <env_vars <clear_env_vars + + +applicable + + <builds + <category + <description + <short_examples <long_examples +}; + +my %TYPES = ( + b => 1, + c => 1, + s => 1, + m => 1, + d => 1, + D => 1, + h => 1, + H => 1, +); +sub valid_type { $TYPES{$_[-1]} } + +my %LONG_TO_SHORT_TYPES = ( + bool => 'b', + boolean => 'b', + + count => 'c', + counter => 'c', + counting => 'c', + + scalar => 's', + string => 's', + number => 's', + + multi => 'm', + multiple => 'm', + list => 'm', + array => 'm', + + default => 'd', + def => 'd', + + 'multi-def' => 'D', + 'multiple-default' => 'D', + 'list-default' => 'D', + 'array-default' => 'D', + + 'hash' => 'h', + 'hash-list' => 'H', +); +sub canon_type { $LONG_TO_SHORT_TYPES{$_[-1]} } + +my %REQUIRES_ARG = (s => 1, m => 1, h => 1, H => 1); +sub requires_arg { $REQUIRES_ARG{$_[0]->{+TYPE}} } + +my %ALLOWS_ARG = (d => 1, D => 1); +sub allows_arg { $ALLOWS_ARG{$_[0]->{+TYPE}} || $REQUIRES_ARG{$_[0]->{+TYPE} } } + +sub init { + my $self = shift; + + confess "You must specify 'title' or both 'field' and 'name'" + unless $self->{+TITLE} || ($self->{+FIELD} && $self->{+NAME}); + + confess "The 'prefix' attribute is required" + unless $self->{+PREFIX}; + + confess "The 'alt' attribute must be an array-ref" + if $self->{+ALT} && ref($self->{+ALT}) ne 'ARRAY'; + + if (my $title = $self->{+TITLE}) { + $self->{+FIELD} //= $title; + $self->{+NAME} //= ($self->{+FROM_PLUGIN} && $self->{+PREFIX}) ? "$self->{+PREFIX}-$title" : $title; + } + + $self->{+FIELD} =~ s/-/_/g; + $self->{+NAME} =~ s/_/-/g; + + if (my $class = $self->{+BUILDS}) { + confess "class '$class' does not have a '$self->{+FIELD}' method" + unless $class->can($self->{+FIELD}) || $self->{+IGNORE_FOR_BUILD}; + } + + $self->{+TYPE} //= 'b'; + $self->{+TYPE} = $self->canon_type($self->{+TYPE}) // $self->{+TYPE} if length($self->{+TYPE}) > 1; + confess "Invalid type '$self->{+TYPE}'" unless $self->valid_type($self->{+TYPE}); + + if ($self->{+TYPE} eq 'd' || $self->{+TYPE} eq 'D') { + $self->{+AUTOFILL} //= 1; + } + elsif(defined $self->{+AUTOFILL}) { + confess "'autofill' not supported for this type ('$self->{+TYPE}')"; + } + + if (my $def = $self->{+DEFAULT}) { + my $ref = ref($def); + confess "'default' must be a simple scalar, or a coderef, got a '$ref'" if $ref && $ref ne 'CODE'; + } + + for my $key (NORMALIZE(), ACTION()) { + my $val = $self->{$key} or next; + my $ref = ref($val) || 'not a ref'; + next if $ref eq 'CODE'; + confess "'$key' must be undef, or a coderef, got '$ref'"; + } + + $self->{+TRACE} //= [caller(1)]; + $self->{+CATEGORY} //= 'NO CATEGORY - FIX ME'; + $self->{+DESCRIPTION} //= 'NO DESCRIPTION - FIX ME'; + + for my $key (sort keys %$self) { + confess "'$key' is not a valid option attribute" + unless $self->can(uc($key)); + } + + return $self; +} + +sub applicable { + my $self = shift; + my ($options) = @_; + my $cb = $self->{+APPLICABLE} or return 1; + return $self->$cb($options); +} + +sub long_args { + my $self = shift; + + return ($self->{+NAME}, @{$self->{+ALT} || []}); +} + +sub option_slot { + my $self = shift; + my ($settings) = @_; + + confess "A settings instance is required" unless $settings; + return $settings->define_prefix($self->{+PREFIX})->vivify_field($self->{+FIELD}); +} + +sub get_default { + my $self = shift; + + for my $var (@{$self->{+ENV_VARS} // []}) { + my ($neg) = $var =~ s/^(!)//; + next unless exists $ENV{$var}; + return !$ENV{$var} if $neg; + return $ENV{$var}; + } + + if (defined $self->{+DEFAULT}) { + my $def = $self->{+DEFAULT}; + + return $self->$def() if ref($def); + + return $def; + } + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return undef; +} + +sub get_normalized { + my $self = shift; + my ($raw) = @_; + + return $self->{+NORMALIZE}->($raw) + if $self->{+NORMALIZE}; + + return $raw ? 1 : 0 + if $self->{+TYPE} eq 'b'; + + if (lc($self->{+TYPE}) eq 'h') { + my ($key, $val) = split /=/, $raw, 2; + + if ($self->{+TYPE} eq 'H') { + $val //= ''; + $val = [split /,/, $val]; + return [$key, $val]; + } + + return [$key, $val // 1]; + } + + return $raw; +} + +my %HANDLERS = ( + c => sub { ${$_[0]}++ }, + m => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + D => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + h => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $val = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + $hash->{$key} = $val; + }, + H => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $vals = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + push @{$hash->{$key} //= []} => @$vals; + }, +); + +sub handle { + my $self = shift; + my ($raw, $settings, $options, $list) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + my $norm = $self->get_normalized($raw); + + my $handler = $HANDLERS{$self->{+TYPE}} //= sub { ${$_[0]} = $_[1] }; + + return $self->{+ACTION}->($self->{+PREFIX}, $self->{+FIELD}, $raw, $norm, $slot, $settings, $handler, $options) + if $self->{+ACTION}; + + return $handler->($slot, $norm); +} + +sub handle_negation { + my $self = shift; + my ($settings, $options) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + + return $self->{+NEGATE}->($self->{+PREFIX}, $self->{+FIELD}, $slot, $settings, $options) + if $self->{+NEGATE}; + + return $$slot = 0 + if $self->{+TYPE} eq 'b' + || $self->{+TYPE} eq 'c'; + + return @{$$slot //= []} = () + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return %{$$slot //= {}} = () + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return $$slot = undef; +} + +sub trace_string { + my $self = shift; + my $trace = $self->{+TRACE} or return "[UNKNOWN]"; + return "$trace->[1] line $trace->[2]"; +} + +my %TYPE_LONG_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]'], + D => ['[=ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_SHORT_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]', '[ARG]'], + D => ['[=ARG]', '[ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_NOTES = ( + 'c' => "Can be specified multiple times", + 'm' => "Can be specified multiple times", + 'D' => "Can be specified multiple times", + 'h' => "Can be specified multiple times", + 'H' => "Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together.", +); + +sub cli_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + + push @forms => "--no-$self->{+NAME}"; + + my @out; + + require App::Yath::Util; + require Test2::Util::Term; + + my $width = Test2::Util::Term::term_size() - 20; + $width = 80 unless $width && $width >= 80; + + push @out => App::Yath::Util::fit_to_width($width, ", ", \@forms); + + my $desc = App::Yath::Util::fit_to_width($width, " ", $self->{+DESCRIPTION}); + $desc =~ s/^/ /gm; + push @out => $desc; + + push @out => "\n Can also be set with the following environment variables: " . join(", ", @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => "\n Note: " . $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join "\n" => @out; +} + +sub pod_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + push @forms => "--no-$self->{+NAME}"; + + my @out = map { "=item $_" } @forms; + + push @out => $self->{+DESCRIPTION}; + + push @out => "Can also be set with the following environment variables: " . join(", ", map { "C<$_>" } @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join("\n\n" => @out) . "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Option - Representation of a yath option. + +=head1 DESCRIPTION + +This class represents a single command line option for yath. + +=head1 SYNOPSIS + +You usually will not be creating option instances directly. Usually you will +use App::Yath::Options which provides sugar, and helps make sure options get to +the right place. + + use App::Yath::Options; + + # You can specify a single option: + option color => ( + prefix => 'display', + category => "Display Options", + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + # If you are specifying multiple options you can use an option_group to + # define common parameters. + option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + }; + +=head1 ATTRIBUTES + +These can be provided at object construction, or are generated internally. + +=head2 CONSTRUCTION ONLY + +=over 4 + +=item applicable => sub { ... } + +This is callback is used by the C<applicable()> method. + + option foo => ( + ..., + applicable => sub { + my ($opt, $options) = @_; + ... + return $bool; + }, + ); + +=back + +=head2 READ-ONLY + +=head3 REQUIRED + +=over 4 + +=item $class->new(prefix => 'my_prefix') + +=item $scalar = $opt->prefix() + +A prefix is required. All options have their values inserted into the settings +structure, an instance of L<Test2::Harness::Settings>. The structure is +C<< $settings->PREFIX->OPTION >>. + +If you do not specify a C<name> attribute then the default name will be +C<PREFIX-TITLE>. The name is the main command line argument, so +C<--PREFIX-TITLE> is the default name. + +=item $class->new(type => $type) + +=item $type = $opt->type() + +All options must have a type, if non is specified the default is C<'b'> aka +boolean. + +Here are all the possible types, along with their aliases. You may use the type +character, or any of the aliases to specify that type. + +=over 4 + +=item b bool boolean + +True of false values, will be normalized to 0 or 1 in most cases. + +=item c count counter counting + +Counter, starts at 0 and then increments every time the option is used. + +=item s scalar string number + +Requires an argument which is treated as a scalar value. No type checking is +done by the option itself, though you can check it using C<action> or +C<normalize> callbacks which are documented under those attributes. + +=item m multi multiple list array + +Requires an argument which is treated as a scalar value. Can be used multiple +times. All arguments provided are appended to an array. + +=item d def default + +Argument is optional, scalar when provided. C<--opt=arg> to provide an +argument, C<--opt arg> will not work, C<arg> will be seen as its own item on +the command line. Can be specified without an arg C<--opt> to signify a default +argument should be used (set via the C<action> callback, not the C<default> +attribute which is a default value regardless of if the option is used.) + +Real world example from the debug options (simplified for doc purposes): + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + # New way to specify an auto-fill value for when no =VAL is provided. + # If you do not specify this the default autofill is '1' for legacy support. + autofill => 'VALUE', + + # Old way to autofill a value (default is 1 for auto-fill) + # Using autofill is significantly better. + # You can also use action for additional behavior along with autofill, + # but the default will be your auto-fill value, not '1'. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # $norm will be '1' if option was used without an argument, so we + # just use the provided value when it is not 1'. + return $$slot = $norm unless $norm eq '1'; + + # $norm was 1, so this is our no-arg "default" behavior + + # Do nothing if a value is already set + return if $$slot; + + # Set the default value of 'summary.json' + return $$slot = 'summary.json'; + }, + ); +}; + +=item D multi-def multiple-default list-default array-default + +This is a combination of C<d> and C<m>. You can use the opt multiple times to +list multiple values, and you can call it without args to add a set of +"default" values (not to be confused with THE default attribute, which is used +even if the option never appears on the command line.) + +Real world example (simplified for doc purposes): + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + # New way to specify the auto-fill values. This may be a single scalar, + # or an arrayref. + autofill => [ 'lib', 'blib/lib', 'blib/arch' ], + + # Old way to specify the auto-fill values. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # If no argument was provided use the 'lib', 'blib/lib', and 'blib/arch' defaults. + # If an argument was provided, use it. + push @{$$slot} => ($norm eq '1') ? ('lib', 'blib/lib', 'blib/arch') : ($norm); + }, + ); + +=item h hash + +The hash type. Each time the option is used it is to add a single key/value pair +to the hash. Use an C<=> sign to split the key and value. The option can be +used multiple times. A value is required. + + yath --opt foo=bar --opt baz=bat + +=item H hash-list + +Similar to the 'h' type except the key/value pair expects a comma separated +list for the value, and it will be placed under the key as an arrayef. + + yath --opt foo=a,b,c --opt bar=1,2,3 + +The yath command obove would produce this structure: + + { + foo => ['a', 'b', 'c'], + bar => ['1', '2', '3'], + } + +=back + +=item $class->new(title => 'my_title') + +=item $title = $opt->title() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +If your title is C<'foo-bar_baz'> then your field will be C<'foo_bar_baz'> and +your name will be C<'$PREFIX-foo-bar-baz'>. + +Basically title is used to generate a sane field and/or name if niether are +specified. For field all dashes are changed to underscores. The field is used +as a key in the settings: C<< $settings->prefix->field >>. For the name all +underscores are changed to dashes, if the option is provided by a plugin then +C<'prefix-'> is prepended as well. The name is used for the command line +argument C<'--name'>. + +If you do not want/like the name and field generated from a title then you can +specify a name or title directly. + +=item $class->new(name => 'my-name') + +=item $name = $opt->name() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +This name is used as your primary command line argument. If your name is C<foo> +then your command line argument is C<--foo>. + +=item $class->new(field => 'my_field') + +=item $field = $opt->field() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +The field is used in the settings hash. If your field is C<foo> then your +settings path is C<< $setting->prefix->foo >>. + +=back + +=head3 OPTIONAL + +=over 4 + +=item $class->new(action => sub ...) + +=item $coderef = $opt->action() + + option foo => ( + ..., + action => sub { + my ($prefix, $field_name, $raw_value, $normalized_value, $slot_ref, $settings, $handler, $options) = @_; + + # If no action is specified the following is all that is normally + # done. Having an action means this is not done, so if you want the + # value stored you must call this or similar. + $handler->($slot, $normalized_value); + }, + ); + +=over 4 + +=item $prefix + +The prefix for the option, specified when the option was defined. + +=item $field_name + +The field for the option, specified whent the option was defined. + +=item $raw_value + +The value/argument provided at the command line C<--foo bar> would give us +C<"bar">. This is BEFORE any processing/normalizing is done. + +For options that do not take arguments, or where argumentes are optional and none are provided, this +will be '1'. + +=item $normalized_value + +If a normalize callback was provided this will be the result of putting the +$raw_value through the normalize callback. + +=item $slot_ref + +This is a scalar reference to the settings slot that holds the option value(s). + +The default behavior when no action is specified is usually one of these: + + $$slot_ref = $normalized_value; + push @{$$slot_ref} => $normalized_value; + +However, to save yourself trouble you can use the C<$handler> instead (see below). + +=item $settings + +The L<Test2::Harness::Settings> instance. + +=item $handler + +A callback that "does the right thing" as far as setting the value in the +settings hash. This is what is used when you do not set an action callback. + + $handler->($slot, $normalized_value); + +=item $options + +The L<App::Yath::Options> instance this options belongs to. This is mainly +useful if you have an option that may add even more options (such as the +C<--plugin> option can do). Note that if you do this you should also set the +C<adds_options> attribute to true, if you do not then the options list will not +be refreshed and your new options may not show up. + +=back + +=item $class->new(adds_options => $bool) + +=item $bool = $opt->adds_options() + +If this is true then it means using this option could result in more options +being available (example: Loading a plugin). + +=item $class->new(alt => ['alt1', 'alt2', ...]) + +=item $arrayref = $opt->alt() + +Provide alternative names for the option. These are aliases that can be used to +achieve the same thing on the command line. This is mainly useful for +backcompat if an option is renamed. + +=item $class->new(builds => 'My::Class') + +=item $my_class = $opt->builds() + +If this option is used in the construction of another object (such as the group +it belongs to is composed of options that translate 1-to-1 to fields in another +object to build) then this can be used to specify that. The ultimate effect is +that an exception will be thrown if that class does not have the correct +attribute. This is a safety net to catch errors early if field names change, or +are missing between this representation and the object being composed. + +=item $class->new(category => 'My Category') + +=item $category = $opt->category() + +This is used to sort/display help and POD documentation for your option. If you +do not provide a category it is set to C<'NO CATEGORY - FIX ME'>. The default +value makes sure everyone knows that you do not know what you are doing :-). + +=item $class->new(clear_env_vars => $bool) + +=item $bool = $opt->clear_env_vars() + +This option is only useful when paired with the C<env_vars> attribute. + +Example: + + option foo => ( + ... + env_vars => ['foo', 'bar', 'baz'], + clear_env_vars => 1, + ): + +In this case you are saying option foo can be set to the value of C<$ENV{foo}>, +C<$ENV{bar}>, or C<$ENV{baz}> vars if any are defined. The C<clear_env_vars> +tell it to then delete the environment variables after they are used to set the +option. This is useful if you want to use the env var to set an option, but do +not want any tests to be able to see the env var after it is used to set the +option. + +=item $class->new(default => $scalar) + +=item $class->new(default => sub { return $default }) + +=item $scalar_or_coderef = $opt->default() + +This sets a default value for the field in the settings hash, the default is +set before any command line processing is done, so if the option is never used +in the command line the default value will be there. + +Be sure to use the correct default value for your type. A scalar for 's', an +arrayref for 'm', etc. + +Note, for any non-scalar type you want to use a subref to define the value: + + option foo => ( + ... + type => 'm', + default => sub { [qw/a b c/] }, + ); + +=item $class->new(description => "Fe Fi Fo Fum") + +=item $multiline_string = $opt->description() + +Description of your option. This is used in help output and POD. If you do not +provide a value the default is C<'NO DESCRIPTION - FIX ME'>. + +=item $class->new(env_vars => \@LIST) + +=item $arrayref = $opt->env_vars() + +If set, this should be an arrayref of environment variable names. If any of the +environment variables are defined then the settings will be updated as though +the option was provided onthe command line with that value. + +Example: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + ); + +Then command line: + + FOO="xxx" yath test + +Should be the same as + + yath test --foo "xxx" + +You can also ask to have the environment variables cleared after they are checked: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + clear_env_vars => 1, # This tells yath to clear the env vars after they + are used. + ); + +If you would like the option set to the opposite of the envarinment variable +you can prefix it with a C<'!'> character: + + option foo =>( + ... + env_vars => ['!FOO'], + ); + +In this case these are equivelent: + + FOO=0 yath test + yath test --foo=1 + +Note that this only works when the variable is defined. If C<$ENV{FOO}> is not +defined then the variable is not used. + +=item $class->new(from_command => 'App::Yath::Command::COMMAND') + +=item $cmd_class = $opt->from_command() + +If your option was defined for a specific command this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(from_plugin => 'App::Yath::Plugin::PLUGIN') + +=item $plugin_class = $opt->from_plugin() + +If your option was defined for a specific plugin this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(long_examples => [' foo', '=bar', ...]) + +=item $arrayref = $opt->long_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<--foo bar> would be wrong, you should just do C< bar>. + +=item $class->new(negate => sub { ... }) + +=item $coderef = $opt->negate() + +If you want a custom handler for negation C<--no-OPT> you can provide one here. + + option foo => ( + ... + negate => sub { + my ($prefix, $field, $slot, $settings, $options) = @_; + + ... + }, + ); + +The variables are the same as those in the C<action> callback. + +=item $class->new(normalize => sub { ... }) + +=item $coderef = $opt->normalize() + +The normalize attribute holds a callback sub that takes the raw value as input +and returns the normalized form. + + option foo => ( + ..., + normalize => sub { + my $raw = shift; + + ... + + return $norm; + }, + ); + +=item $class->new(pre_command => $bool) + +=item $bool = $opt->pre_command() + +Options are either command-specific, or pre-command. Pre-command options are +ones yath processes even if it has not determined what comamnd is being used. +Good examples are C<--dev-lib> and C<--plugin>. + + yath --pre-command-opt COMMAND --command-opt + +Most of the time this should be false, very few options qualify as pre-command. + +=item $class->new(pre_process => sub { ... }) + +=item $coderef = $opt->pre_process() + +This is essentially a BEGIN block for options. This callback is called as soon +as the option is parsed from the command line, well before the value is +normalized and added to settings. A good use for this is if your option needs +to inject additional L<App::Yath::Option> instances into the +L<App::Yath::Options> instance. + + option foo => ( + ... + + pre_process => sub { + my %params = @_; + + my $opt = $params{opt}; + my $options = $params{options}; + my $action = $params{action}; + my $type = $params{type}; + my $val = $params{val}; + + ...; + }, + ); + +Explanation of paremeters: + +=over 4 + +=item $params{opt} + +The op instance + +=item $params{options} + +The L<App::Yath::Options> instance. + +=item $params{action} + +A string, usually either "handle" or "handle_negation" + +=item $params{type} + +A string, usually C<"pre-command"> or C<"command ($CLASS)"> where the second +has the command package in the parentheses. + +=item $params{val} + +The value being set, if any. For options that do not take arguments, or in the +case of negation this key may not exist. + +=back + +=item $class->new(short => $single_character_string) + +=item $single_character_string = $opt->short() + +If you want your option to be usable as a short option (single character, +single dash C<-X>) then you can provide the character to use here. If the +option does not require an argument then it can be used along with other +no-argument short options: C<-xyz> would be equivilent to C<-x -y -z>. + +There are only so many single-characters available, so options are restricted +to picking only 1. + +B<Please note:> Yath reserves the right to add any single-character short +options in the main distribution, if they conflict with third party +plugins/commands then the third party must adapt and change its options. As +such it is not recommended to use any short options in third party addons. + +=item $class->new(short_examples => [' foo', ...]) + +=item $arrayref = $opt->short_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<-f bar> would be wrong, you should just do C< bar>. + +This attribute is not used if you do not provide a C<short> attribute. + +=item $class->new(trace => [$package, $file, $line]) + +=item $arrayref = $opt->trace() + +This is almost always auto-populated for you via C<caller()>. It should be an +arrayref with a package, filename and line number. This is used if there is a +conflict between parameter names and/or short options. If such a situation +arises the file/line number of all conflicting options will be reported so it +can be fixed. + +=back + +=head1 METHODS + +=over 4 + +=item $bool = $opt->allows_arg() + +True if arguments can be provided to the option (based on type). This does not +mean the option MUST accept arguments. 'D' type options can accept arguments, +but can also be used without arguments. + +=item $bool = $opt->applicable($options) + +If an option provides an applicability callback this will use it to determine +if the option is applicable given the L<App::Yath::Options> instance. + +If no callback was provided then this returns true. + +=item $character = $opt->canon_type($type_name) + +Given a long alias for an option type this will return the single-character +canonical name. This will return undef for any unknown strings. This will not +translate single character names to themselves, so C<< $opt->canon_type('s') >> +will return undef while C<< $opt->canon_type('string') >> will return C<'s'>. + +=item $val = $opt->get_default() + +This will return the proper default value for the option. If a custom default +was provided it will be returned, otherwise the correct generic default for the +option type will be used. + +Here is a snippet showing the defaults for types: + + # First check env vars and return any values from there + ... + # Then check for a custom default and use it. + ... + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + # All others get undef + return undef; + +=item $val $opt->get_normalized($raw) + +This converts a raw value to a normalized one. If a custom C<normalize> +attribute was set then it will be used, otherwise it is normalized in +accordance to the type. + +This is where booleans are turned into 0 or 1, hashes are split, hash-lists are +split further, etc. + +=item $opt->handle($raw, $settings, $options, $list) + +This method handles setting the value in $settings. You should not normally +need to call this yourself. + +=item $opt->handle_negation() + +This method is used to handle a negated option. You should not normally need to +call this yourself. + +=item @list = $opt->long_args() + +Returns the name and any aliases. + +=item $ref = $opt->option_slot($settings) + +Get the settings->prefix->field reference. This creates the setting field if +necessary. + +=item $bool = $opt->requires_arg() + +Returns true if this option requires an argument when used. + +=item $string = $opt->trace_string() + +return a string like C<"somefile.pm line 42"> based on where the option was +defined. + +=item $bool = $opt->valid_type($character) + +Check if a single character type is valid. + +=back + +=head2 DOCUMENTATION GENERATION + +=over 4 + +=item $string = $opt->cli_docs() + +Get the option documentation in a format that works for the C<yath help +COMMAND> command. + +=item $string = $opt->pod_docs() + +Get the option documentation in POD format. + + =item .... + + .. option details ... + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options.pm b/libold2/App/Yath/Options.pm new file mode 100644 index 000000000..42193254d --- /dev/null +++ b/libold2/App/Yath/Options.pm @@ -0,0 +1,935 @@ +package App::Yath::Options; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Option(); +use Test2::Harness::Settings(); + +use Test2::Harness::Util::HashBase qw{ + <all <lookup + + <pre_list <cmd_list <post_list + + <post_list_sorted + + <settings + + <args + <command_class + + <pending_pre <pending_cmd <pending_post + + <used_plugins + + <included + + <set_by_cli +}; + +sub import { + my $class = shift; + my $caller = caller(); + + croak "$caller already has an 'options' method" + if defined(&{"$caller\::options"}); + + my @common; + my $instance; + my $options = sub { ($instance //= $class->new()) }; + my $option = sub { ($instance //= $class->new())->_option([caller()], shift(@_), @common ? (%{$common[-1]}) : (), @_) }; + my $include = sub { ($instance //= $class->new())->include_from(@_) }; + + my $post = sub { + my $cb = pop; + my $weight = shift // 0; + my ($applicable) = @_; + + $applicable //= $common[-1]->{applicable} if @common; + + croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE'; + + ($instance //= $class->new())->_post($weight, $applicable, $cb); + }; + + my $group = sub { + my ($set, $sub) = @_; + + my $common = {@common ? (%{$common[-1]}) : (), %$set}; + + if (my $class = $common->{builds}) { + require(mod2file($class)); + } + + push @common => $common; + my $ok = eval { $sub->(); 1 }; + my $err = $@; + pop @common; + + die $err unless $ok; + }; + + { + no strict 'refs'; + *{"$caller\::post"} = $post; + *{"$caller\::option"} = $option; + *{"$caller\::options"} = $options; + *{"$caller\::option_group"} = $group; + *{"$caller\::include_options"} = $include; + } + + return 1; +} + +sub init { + my $self = shift; + + $self->{+ALL} //= []; + $self->{+LOOKUP} //= {}; + + $self->{+USED_PLUGINS} //= []; + + $self->{+PRE_LIST} //= []; + $self->{+CMD_LIST} //= []; + $self->{+POST_LIST} //= []; + + $self->{+SETTINGS} //= Test2::Harness::Settings->new(); + + $self->{+INCLUDED} //= {}; + + $self->{+SET_BY_CLI} //= {}; + + return $self; +} + +sub option { + my $self = shift; + $self->_option([caller()], @_); +} + +sub include { + my $self = shift; + my ($inc) = @_; + + croak "Include must be an instance of ${ \__PACKAGE__ }, got ${ defined($inc) ? \qq['$inc'] : \'undef' }" + unless $inc && blessed($inc) && $inc->isa(__PACKAGE__); + + $self->include_option($_) for @{$inc->all}; + + $self->{+POST_LIST_SORTED} = 0; + push @{$self->{+POST_LIST}} => @{$inc->post_list}; + + return; +} + +sub include_from { + my $self = shift; + + for my $pkg (@_) { + require(mod2file($pkg)) unless $pkg->can('options'); + + next unless $pkg->can('options'); + my $options = $pkg->options or next; + $self->include($options); + + $self->{+INCLUDED}->{$pkg}++; + $self->{+INCLUDED}->{$_}++ for keys %{$options->included}; + } + + return; +} + +sub populate_pre_defaults { + my $self = shift; + + for my $opt (@{$self->_pre_command_options}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub populate_cmd_defaults { + my $self = shift; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + for my $opt (@{$self->_command_options()}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub grab_pre_command_opts { + my $self = shift; + my %config = @_; + + $self->populate_pre_defaults(); + + unshift @{$self->{+PENDING_PRE} //= []} => $self->_grab_opts( + '_pre_command_options', + 'pre-command', + stop_at_non_opt => 1, + passthrough => 1, + %config, + ); +} + +sub process_pre_command_opts { + my $self = shift; + return unless $self->{+PENDING_PRE}; + $self->_process_opts(delete $self->{+PENDING_PRE}); +} + +sub set_command_class { + my $self = shift; + my ($in) = @_; + + croak "Command class has already been set" + if $self->{+COMMAND_CLASS}; + + my $class = blessed($in) || $in; + + croak "Invalid command class: $class" + unless $class->isa('App::Yath::Command'); + + $self->include_from($class) if $class->can('options'); + + return $self->{+COMMAND_CLASS} = $class; +} + +sub set_args { + my $self = shift; + my ($in) = @_; + + croak "'args' has already been set" + if $self->{+ARGS}; + + return $self->{+ARGS} = $in; +} + +sub grab_command_opts { + my $self = shift; + my %config = @_; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + $self->populate_cmd_defaults(); + + push @{$self->{+PENDING_CMD} //= []} => $self->_grab_opts( + '_command_options', + "command (" . $self->{+COMMAND_CLASS}->name . ")", + %config, + ); +} + +sub process_command_opts { + my $self = shift; + return unless $self->{+PENDING_CMD}; + $self->_process_opts(delete $self->{+PENDING_CMD}); +} + +sub process_option_post_actions { + my $self = shift; + my ($cmd) = @_; + + croak "The 'args' attribute has not yet been set" + unless $self->{+ARGS}; + + if ($cmd) { + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + croak "The process_option_post_actions requires an App::Yath::Command instance, got: " . ($cmd // "undef") + unless blessed($cmd) && $cmd->isa('App::Yath::Command'); + + croak "The command '$cmd' dos not match the expected class '$self->{+COMMAND_CLASS}'" + unless blessed($cmd) eq $self->{+COMMAND_CLASS}; + } + + unless ($self->{+POST_LIST_SORTED}++) { + @{$self->{+POST_LIST}} = sort { $a->[0] <=> $b->[0] } @{$self->{+POST_LIST}}; + } + + for my $post (@{$self->{+POST_LIST}}) { + next if $post->[1] && !$post->[1]->($post->[2], $self); + $post->[2]->( + options => $self, + args => $self->{+ARGS}, + settings => $self->{+SETTINGS}, + $cmd ? (command => $cmd) : (), + ); + } +} + +sub _pre_command_options { $_[0]->{+PRE_LIST} } + +sub _command_options { + my $self = shift; + + my $class = $self->{+COMMAND_CLASS} or croak "The 'command_class' attribute has not yet been set"; + + my $cmd = $class->name; + my $cmd_options = $self->{+CMD_LIST} // []; + my $pre_options = $self->{+PRE_LIST} // []; + + return [grep { $_->applicable($self) } @$cmd_options, @$pre_options]; +} + +sub _process_opts { + my $self = shift; + my ($list) = @_; + + while (my $opt_set = shift @$list) { + my ($opt, $meth, @args) = @$opt_set; + $opt->$meth(@args, $self->{+SETTINGS}, $self, $list); + $self->{+SET_BY_CLI}->{$opt->prefix}->{$opt->field}++; + push @{$self->{+USED_PLUGINS}} => $opt->from_plugin if $opt->from_plugin; + } +} + +sub _parse_long_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^--((?:no-)?([^=]+))(=(.*))?$/ or confess "Invalid long option: $arg"; + + #return (main, full, val); + return ($2, $1, $3 ? $4 // '' : undef); +} + +sub _parse_short_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^-([^-])(=)?(.+)?$/ or confess "Invalid short option: $arg"; + + #return (main, remain, assign); + return ($1, $3, $2); +} + +sub _handle_long_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $full, $val) = $self->_parse_long_option($arg); + + my $opt; + if ($opt = $lookup->{long}->{$full}) { + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option --$full requires an argument.\n"; + } + elsif($opt->allows_arg) { + $val //= $opt->autofill // 1; + } + else { + die "Option --$full does not take an argument\n" if defined $val; + $val = 1; + } + + return [$opt, 'handle', $val]; + } + elsif ($opt = $lookup->{long}->{$main}) { + die "Option --$full does not take an argument\n" if defined $val; + return [$opt, 'handle_negation']; + } + + return undef; +} + +sub _handle_short_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $remain, $assign) = $self->_parse_short_option($arg); + + if (my $opt = $lookup->{short}->{$main}) { + if ($opt->allows_arg) { + my $val = $remain; + + $val //= '' if $assign; + + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option -$main requires an argument.\n"; + } + else { + $val //= $opt->autofill // 1; + } + + $val //= 1; + return [$opt, 'handle', $val]; + } + elsif ($assign) { + die "Option -$main does not take an argument\n"; + } + elsif(defined($remain) && length($remain)) { + unshift @$args => "-$remain"; + } + + return [$opt, 'handle', 1]; + } + + return undef; +} + +my %ARG_ENDS = ('--' => 1, '::' => 1); + +sub _grab_opts { + my $self = shift; + my ($opt_fetch, $type, %config) = @_; + + croak "The opt_fetch callback is required" unless $opt_fetch; + croak "The arg type is required" unless $type; + + my $args = $config{args} || $self->{+ARGS} or confess "The 'args' attribute has not yet been set"; + + my $lookup = $self->_build_lookup($self->$opt_fetch()); + + my (@keep_args, @opts); + while (@$args) { + my $arg = shift @$args; + + if ($ARG_ENDS{$arg}) { + push @keep_args => $arg; + last; + } + + if (substr($arg, 0, 1) eq '-') { + my $handler = (substr($arg, 1, 1) eq '-') ? '_handle_long_option' : '_handle_short_option'; + if(my $opt_set = $self->$handler($arg, $lookup, $args)) { + my ($opt, $action, @val) = @$opt_set; + + if (my $pre = $opt->pre_process) { + $pre->( + opt => $opt, + options => $self, + action => $action, + type => $type, + + @val ? (val => $val[0]) : (), + ); + } + + $lookup = $self->_build_lookup($self->$opt_fetch()) + if $opt->adds_options; + + push @opts => $opt_set; + next; + } + elsif (!$config{passthrough}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + } + + if ($config{die_at_non_opt}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + + push @keep_args => $arg; + + last if $config{stop_at_non_opt}; + } + + unshift @$args => @keep_args; + + return @opts; +} + +sub _build_lookup { + my $self = shift; + my ($opts) = @_; + + my $lookup = {long => {}, short => {}}; + + my %seen; + for my $opt (@$opts) { + next if $seen{$opt}++; + + for my $long ($opt->long_args) { + $lookup->{long}->{$long} //= $opt; + } + + my $short = $opt->short or next; + $lookup->{short}->{$short} //= $opt; + } + + return $lookup; +} + +sub _post { + my $self = shift; + my ($weight, $applicable, $cb) = @_; + + $self->{+POST_LIST_SORTED} = 0; + + $weight //= 0; + + push @{$self->{+POST_LIST} //= []} => [$weight, $applicable, $cb]; +} + +sub _option { + my $self = shift; + my ($trace, @spec) = @_; + + my %proto = $self->_parse_option_args(@spec); + + my $opt = App::Yath::Option->new( + trace => $trace, + $self->_parse_option_caller($trace->[0], \%proto), + %proto, + ); + + $self->include_option($opt); +} + +sub include_option { + my $self = shift; + my ($opt) = @_; + + my $trace = $opt->trace or confess "Options must have a trace!"; + + push @{$self->{+ALL}} => $opt; + + my $new = $self->_index_option($opt); + $self->_list_option($opt) if $new; + + return $opt; +} + +sub _parse_option_caller { + my $self = shift; + my ($caller, $proto) = @_; + + my ($from_plugin, $from_command, $from_prefix, $prefix, $is_top); + + $prefix = $proto->{prefix} if exists $proto->{prefix}; + $prefix //= $caller->option_prefix() if $caller->can('option_prefix'); + + if ($caller->isa('App::Yath::Command')) { + $from_command = $caller->name() unless $caller eq 'App::Yath::Command'; + $is_top = 1; + } + elsif ($caller =~ m/App::Yath::Command::([^:]+)::.*Options(?:::.*)?$/) { + $from_command = $1; + $is_top = 1; + } + elsif ($caller eq 'App::Yath') { + $is_top = 1; + } + elsif ($caller =~ m/^(App::Yath::Plugin::([^:]+))$/) { + $from_plugin = $1; + $from_prefix = $2; + + unless (defined $prefix) { + $prefix = $from_prefix; + $prefix =~ s/::.*$//g; + } + } + + $prefix = lc($prefix) if $prefix; + + croak "Could not find an option prefix and option is not top-level ($proto->{title})" + unless $is_top || defined($prefix) || defined($proto->{prefix}); + + return ( + $from_plugin ? (from_plugin => $from_plugin) : (), + $from_command ? (from_command => $from_command) : (), + ($prefix || !$is_top) ? (prefix => $prefix) : (), + ); +} + +sub _parse_option_args { + my $self = shift; + my @spec = @_; + + my %args; + if (@spec == 1) { + my ($title, $type) = $spec[0] =~ m/^([\w-]+)(?:=(.+))?$/ or croak "Invalid option specification: $spec[0]"; + return (title => $title, type => $type); + } + elsif (@spec == 2) { + my ($title, $type) = @spec; + return (title => $title, type => $type); + } + + my $title = shift @spec; + return (title => $title, @spec); +} + +sub _index_option { + my $self = shift; + my ($opt) = @_; + + my $index = $self->{+LOOKUP}; + + my $out = 0; + + for my $n ($opt->name, @{$opt->alt || []}) { + if (my $existing = $index->{$n}) { + next if "$existing" eq "$opt"; + croak "Option '$n' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$n} = $opt; + } + + if (my $short = $opt->short) { + if (my $existing = $index->{$short}) { + return $out if "$existing" eq "$opt"; + croak "Option '$short' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$short} = $opt; + } + + return $out; +} + +sub _list_option { + my $self = shift; + my ($opt) = @_; + + return push @{$self->{+PRE_LIST}} => $opt + if $opt->pre_command; + + push @{$self->{+CMD_LIST}} => $opt; +} + +sub pre_docs { + my $self = shift; + + return $self->_docs($self->_pre_command_options(), @_); +} + +sub cmd_docs { + my $self = shift; + + return unless $self->{+COMMAND_CLASS}; + + return $self->_docs([grep { !$_->pre_command } @{$self->_command_options()}], @_); +} + +my %DOC_FORMATS = ( + 'cli' => [ + 'cli_docs', # Method to call on opt + "\n", # how to join lines + sub { "\n$_[1]" }, # how to render the category + sub { $_[0] =~ s/^/ /mg; "$_[0]\n" }, # transform the value from the opt + sub { }, # add this at the end + ], + 'pod' => [ + 'pod_docs', # Method to call on opt + "\n\n", # how to join lines + sub { ($_[0] ? ("=back") : (), "=head$_[2] $_[1]", "=over 4") }, # how to render the category + sub { $_[0] }, # transform the value from the opt + sub { $_[0] ? ("=back") : () }, # add this at the end + ], +); + +sub _docs { + my $self = shift; + my ($opts, $format, @args) = @_; + + $format //= "UNDEFINED"; + my $fset = $DOC_FORMATS{$format} or croak "Invalid documentation format '$format'"; + my ($fmeth, $join, $fcat, $ftrans, $fend) = @$fset; + + return unless $opts; + return unless @$opts; + + my @opts = sort _doc_sort_ops @$opts; + + my @out; + + my $cat; + for my $opt (@opts) { + if (!$cat || $opt->category ne $cat) { + push @out => $fcat->($cat, $opt->category, @args); + $cat = $opt->category; + } + + my $help = $opt->$fmeth(); + push @out => $ftrans->($help); + } + + push @out => $fend->($cat); + + return join $join => @out; +} + +sub _doc_sort_ops($$) { + my ($a, $b) = @_; + + my $anc = $a->category eq 'NO CATEGORY - FIX ME'; + my $bnc = $b->category eq 'NO CATEGORY - FIX ME'; + + if($anc xor $bnc) { + return 1 if $anc; + return -1; + } + + my $ret = $a->category cmp $b->category; + $ret ||= ($a->prefix || '') cmp ($b->prefix || ''); + $ret ||= $a->field cmp $b->field; + $ret ||= $a->name cmp $b->name; + + return $ret; +} + +sub clear_env { + my $self = shift; + + for my $opt (@{$self->{+ALL}}) { + next unless $opt->clear_env_vars; + my $env = $opt->env_vars or next; + for my $var (@$env) { + $var =~ s/^!//; + delete $ENV{$var}; + } + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options - Tools for defining and tracking yath CLI options. + +=head1 DESCRIPTION + +This class represents a collection of options, and holds the logic for +processing them. This package also exports sugar to help you define options. + +=head1 SYNOPSIS + + package My::Options; + + use App::Yath::Options; + + # This package now has a package instance of options, which can be obtained + # via the options() method. + my $options = __PACKAGE__->options; + + # We can include options from other packages + include_options( + 'Package::With::Options::A', + 'Package::With::Options::B', + ..., + ); + + # Define an option group with some options + option_group { %common_fields } => sub { + + # Define an option + option foo => ( + type => 's', + default => "FOOOOOOO", + category => 'foo', + description => "This is foo" + long_examples => [' value'], + ... + ); + + option bar => ( ... ); + ... + }; + + # Action to call right after options are parsed. + post sub { + my %params = @_; + + ... + }; + +=head1 EXPORTS + +=over 4 + +=item $opts = options() + +=item $opts = $class->options() + +This returns the options instance associated with your package. + +=item include_options(@CLASSES) + +This lets you include options defined in other packages. + +=item option_group \%COMMON_FIELDS => sub { ... } + +An option group is simply a block where all calls to C<option()> will have +common fields added automatically, this makes it easier to define multiple +options that share common fields. Common fields can be overridden inside the +option definition. + +These are both equivalent: + + # Using option group + option_group { category => 'foo', prefix => 'foo' } => sub { + option a => (type => 'b'); + option b => (type => 's'); + }; + + # Not using option group + option a => (type => 'b', category => 'foo', prefix => 'foo'); + option b => (type => 's', category => 'foo', prefix => 'foo'); + +=item option TITLE => %FIELDS + +Define an option. The first argument is the C<title> attribute for the new +option, all other arguments should be attribute/value pairs used to construct +the option. See L<App::Yath::Option> for the documentation of attributes. + +=item post sub { ... } + +=item post $weight => sub { ... } + +C<post> callbacks are run after all command line arguments have been processed. +This is a place to verify the result of several options combined, sanity check, +or even add short-circuit behavior. This is how the C<--help> and +C<--show-opts> options are implemented. + +If no C<$weight> is specified then C<0> is used. C<post> callbacks or sorted +based on weight with higher values being run later. + +=back + +=head1 OPTIONS INSTANCES + +In general you should not be using the options instance directly. Options +instances are mostly an implementation detail that should be treated as a black +box. There are however a few valid reasons to interact with them directly. In +those cases there are a few public attributes/methods you can work with. This +section documents the public interface. + +=head2 ATTRIBUTES + +This section only lists attributes that may be useful to people working with +options instances. There are a lot of internal (to yath) attributes that are +implementation details that are not listed here. Attributes not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $arrayref = $options->all + +Arrayref containing all the L<App::Yath::Option> instances in the options +instance. + +=item $settings = $options->settings + +Get the L<Test2::Harness::Settings> instance. + +=item $arrayref = $options->args + +Get the reference to the list of command line arguments. This list is modified +as arguments are processed, there are no guarentees about what is in here at +any given stage of argument processing. + +=item $class_name = $options->command_class + +If yath has determined what command is being executed this will be populated +with that command class. This will be undefined if the class has not been +determined yet. + +=item $arrayref = $options->used_plugins + +This is a list of all plugins who's options have been used. Plugins may appear +more than once. + +=item $hashref = $options->included + +A hashref where every key is a package who's options have been included into +this options instance. The values are an implementation detail, do not rely on +them. + +=back + +=head2 METHODS + +This section only lists methods that may be useful to people working with +options instances. There are a lot of internal (to yath) methods that are +implementation details that are not listed here. Methods not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $opt = $options->option(%OPTION_ATTRIBUTES) + +This will create a new option with the provided attributes and add it to the +options instance. A C<trace> attribute will be automatically set for you. + +=item $options->include($options_instance) + +This method lets you directly include options from a second instance into the +first. + +=item $options->include_from(@CLASSES) + +This lets you include options from multiple classes that have options defined. + +=item $options->include_option($opt) + +This lets you include a single already defined option instance. + +=item $options->pre_docs($format, @args) + +Get documentation for pre-command options. $format may be 'cli' or 'pod'. + +=item $options->cmd_docs($format, @args) + +Get documentation for command options. $format may be 'cli' or 'pod'. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Collector.pm b/libold2/App/Yath/Options/Collector.pm new file mode 100644 index 000000000..e60ed5d85 --- /dev/null +++ b/libold2/App/Yath/Options/Collector.pm @@ -0,0 +1,89 @@ +package App::Yath::Options::Collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +option_group {prefix => 'collector', category => "Collector Options"} => sub { + option max_open_jobs => ( + type => 's', + description => 'Maximum number of jobs a collector can process at a time, if more jobs are pending their output will be delayed until the earlier jobs have been processed. (Default: double the -j value)', + long_examples => [' 18'], + short_examples => [' 18'], + ); + + option max_poll_events => ( + type => 's', + description => 'Maximum number of events to poll from a job before jumping to the next job. (Default: 1000)', + default => 1000, + long_examples => [' 1000'], + short_examples => [' 1000'], + ); + + post \&collector_post; +}; + +sub collector_post { + my %params = @_; + my $settings = $params{settings}; + + unless ($settings->collector->max_open_jobs) { + my $j = $settings->runner->job_count // 1; + my $max_open = 2 * $j; + $settings->collector->field(max_open_jobs => $max_open); + } +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Collector - collector options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the collector are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Debug.pm b/libold2/App/Yath/Options/Debug.pm new file mode 100644 index 000000000..d728d48bc --- /dev/null +++ b/libold2/App/Yath/Options/Debug.pm @@ -0,0 +1,338 @@ +package App::Yath::Options::Debug; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries mod2file clean_path/; + +use Errno qw/EINTR/; + +use App::Yath::Options; + +option_group {prefix => 'debug', category => 'Help and Debugging'} => sub { + post 99999 => \&_post_process_show_opts; + post 99998 => \&_post_process_interactive; + post \&_post_process_version; + post \&_post_process_help; + + option dummy => ( + short => 'd', + description => 'Dummy run, do not actually execute anything', + env_vars => [qw/T2_HARNESS_DUMMY/], + clear_env_vars => 1, + default => 0, + ); + + option procname_prefix => ( + type => 's', + default => '', + description => 'Add a prefix to all proc names (as seen by ps).', + ); + + option keep_dirs => ( + short => 'k', + alt => ['keep_dir'], + description => 'Do not delete directories when done. This is useful if you want to inspect the directories used for various commands.', + default => 0, + ); + + option 'show-opts' => ( + description => 'Exit after showing what yath thinks your options mean', + pre_command => 1, + ); + + option version => ( + short => 'V', + description => "Exit after showing a helpful usage message", + pre_command => 1, + ); + + option help => ( + short => 'h', + description => "exit after showing help information", + ); + + option interactive => ( + short => 'i', + description => 'Use interactive mode, 1 test at a time, stdin forwarded to it', + ); + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + normalize => \&normalize_summary, + action => \&summary_action, + applicable => sub { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; + }, + ); +}; + +sub normalize_summary { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub summary_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('summary.json'); +} + +sub _post_process_help { + my %params = @_; + + return unless $params{settings}->debug->help; + + my $help; + if (my $cmd = $params{command}) { + $help = $cmd->cli_help(%params); + } + else { + $help = __PACKAGE__->cli_help(%params); + } + + if (eval { require IO::Pager; 1 }) { + local $SIG{PIPE} = sub {}; + my $pager = IO::Pager->new(*STDOUT); + $pager->print($help); + } + else { + print $help; + } + + exit 0; +} + +sub _post_process_show_opts { + my %params = @_; + + return unless $params{settings}->debug->show_opts; + + my $settings = $params{settings}; + + print "\nCommand selected: " . $params{command}->name . " (" . ref($params{command}) . ")\n" if $params{command}; + + my $args = $params{args}; + print "\nCommand args: " . join(', ' => @$args) . "\n" if @$args; + + my $out = encode_pretty_json($settings); + + print "\nCurrent command line and config options result in these settings:\n"; + print "$out\n"; + + exit 0; +} + +my $RAN = 0; +sub _post_process_interactive { + return if $RAN++; + my %params = @_; + + return unless $params{settings}->debug->interactive; + + my $settings = $params{settings}; + + my ($fifo); + if ($settings->check_prefix('workspace')) { + my $dir = $settings->workspace->workdir; + $fifo = "$dir/fifo-$$"; + } + else { + require File::Temp; + my $fh; + ($fh, $fifo) = File::Temp::tempfile("YATH-FIFO-$$-XXXXXX", TMPDIR => 1); + close($fh); + unlink($fifo); + } + + ${$settings->debug->vivify_field('fifo')} = $fifo; + + if ($settings->check_prefix('display')) { + $settings->display->field(quiet => 0); + $settings->display->field(verbose => 1) unless $settings->display->verbose; + } + + if ($settings->check_prefix('formatter')) { + $settings->formatter->field(qvf => 0); + } + + if ($settings->check_prefix('run')) { + $settings->run->env_vars->{YATH_INTERACTIVE} = $fifo; + $ENV{YATH_INTERACTIVE} = $fifo; + } + + my $pid = fork() // die "Could not fork: $!"; + if ($pid) { + require Scope::Guard; + require POSIX; + POSIX::mkfifo($fifo, 0700) or die "Failed to make fifo ($fifo): $!"; + my $fh; + + my $cleanup = sub { + close($fh) if $fh; + unlink($fifo) if -e $fifo; + }; + + my $old_int_handler = $SIG{INT}; + my $old_term_handler = $SIG{TERM}; + + $SIG{INT} = sub { $cleanup->('INT'); $old_int_handler->() if ref $old_int_handler; exit 1; }; + $SIG{TERM} = sub { $cleanup->('TERM'); $old_term_handler->() if ref $old_term_handler; exit 1; }; + $SIG{PIPE} = sub { exit 1 }; + + $SIG{CHLD} = sub { + my $res = waitpid($pid, 0); + my $exit = ($? >> 8); + + close($fh) if $fh; + unlink($fifo) if -e $fifo; + + # Forward the exit code from our child + exit($exit); + }; + + for (1 .. 10) { + last if open($fh, '>', $fifo); + die "Could not open fifo ($fifo): $!" unless $! == EINTR; + sleep 1; + } + die "Could not open fifo ($fifo): $!" unless $fh; + + $fh->autoflush(1); + my $guard = Scope::Guard->new($cleanup); + + while(1) { + my $data = <STDIN>; + if (defined($data) && length($data)) { + print $fh $data; + next; + } + + next if defined($data); + + next if kill(0, $pid); + print STDERR "Lost child process $pid\n"; + $cleanup->(); + exit 255; + } + } + + close(STDIN); + open(STDIN, '<', '/dev/null'); + + require Time::HiRes; + while (! -e $fifo) { Time::HiRes::sleep(0.1) }; +} + +sub _post_process_version { + my %params = @_; + + return unless $params{settings}->debug->version; + + require App::Yath; + my $out = <<" EOT"; + +Yath version: $App::Yath::VERSION + +Extended Version Info + EOT + + my $plugin_libs = find_libraries('App::Yath::Plugin::*'); + + my @vers = ( + [perl => $^V], + ['App::Yath' => App::Yath->VERSION], + ( + map { + eval { require(mod2file($_)); 1 } + ? [$_ => $_->VERSION // 'N/A'] + : [$_ => 'N/A'] + } qw/Test2::API Test2::Suite Test::Builder/ + ), + ( + map { + eval { require($plugin_libs->{$_}); 1 } + && [$_ => $_->VERSION // 'N/A'] + } sort keys %$plugin_libs + ), + ); + + $out .= join "\n" => table( + header => [qw/COMPONENT VERSION/], + rows => \@vers, + ); + + print "$out\n\n"; + + exit 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Debug - Debug options for Yath + +=head1 DESCRIPTION + +This is where debug related command line options live. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Display.pm b/libold2/App/Yath/Options/Display.pm new file mode 100644 index 000000000..0deaf119f --- /dev/null +++ b/libold2/App/Yath/Options/Display.pm @@ -0,0 +1,237 @@ +package App::Yath::Options::Display; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + + option no_wrap => ( + type => 'b', + description => "Do not do fancy text-wrapping, let the terminal handle it", + default => 0, + ); + + option show_times => ( + short => 'T', + description => 'Show the timing data for each job', + ); + + option hide_runner_output => ( + description => 'Hide output from the runner, showing only test output. (See Also truncate_runner_output)', + default => 0, + ); + + option truncate_runner_output => ( + description => 'Only show runner output that was generated after the current command. This is only useful with a persistent runner.', + default => 0, + ); + + option term_width => ( + type => 's', + alt => ['term-size'], + description => 'Alternative to setting $TABLE_TERM_SIZE. Setting this will override the terminal width detection to the number of characters specified.', + long_examples => [' 80', ' 200'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + $ENV{TABLE_TERM_SIZE} = $norm; + }, + ); + + option 'progress' => ( + default => sub { -t STDOUT ? 1 : 0 }, + + description => "Toggle progress indicators. On by default if STDOUT is a TTY. You can use --no-progress to disable the 'events seen' counter and buffered event pre-display", + ); + + option renderers => ( + alt => ['renderer'], + type => 'H', + + description => 'Specify renderers, (Default: "Formatter=Test2"). Use "+" to give a fully qualified module name. Without "+" "Test2::Harness::Renderer::" will be prepended to your argument.', + + long_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + short_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($class, $args) = @$norm; + + $class = "Test2::Harness::Renderer::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + my $ok = eval { require $file; 1 }; + warn "Failed to load renderer '$class': $@" unless $ok; + + $handler->($slot, [$class, $args]); + }, + ); + + post 100 => sub { + my %params = @_; + my $settings = $params{settings}; + + my $display = $settings->display; + my $renderers = $display->renderers; + + my $quiet = $display->quiet; + my $verbose = $display->verbose; + + die "The 'quiet' and 'verbose' options may not be used together.\n" + if $verbose && $quiet; + + if ($quiet) { + delete $renderers->{'Test2::Harness::Renderer::Formatter'}; + @{$renderers->{'@'}} = grep { $_ ne 'Test2::Harness::Renderer::Formatter' } @{$renderers->{'@'}}; + return; + } + + my @args = map { $_ => $settings->formatter->$_ } qw{ + formatter + show_run_info + show_job_info + show_job_launch + show_job_end + }; + + push @args => map { $_ => $settings->display->$_ } qw{ + progress + color + quiet + verbose + show_times + }; + + if (my $formatter_args = $renderers->{'Test2::Harness::Renderer::Formatter'}) { + @$formatter_args = @args unless @$formatter_args; + return; + } + + return if $renderers->{'@'} && @{$renderers->{'@'}}; + + push @{$renderers->{'@'}} => 'Test2::Harness::Renderer::Formatter'; + $renderers->{'Test2::Harness::Renderer::Formatter'} = \@args; + }; +}; + +option_group {prefix => 'formatter', category => "Formatter Options"} => sub { + option formatter => ( + type => 's', + ); + + option 'qvf' => ( + description => '[Q]uiet, but [V]erbose on [F]ailure. Hide all output from tests when they pass, except to say they passed. If a test fails then ALL output from the test is verbosely output.', + ); + + option show_job_end => ( + description => 'Show output when a job ends. (Default: on)', + default => 1, + ); + + option show_job_info => ( + description => 'Show the job configuration when a job starts. (Default: off, unless -vv)', + default => 0, + ); + + option show_job_launch => ( + description => "Show output for the start of a job. (Default: off unless -v)", + default => 0, + ); + + option show_run_info => ( + description => 'Show the run configuration when a run starts. (Default: off, unless -vv)', + default => 0, + ); + + post 90 => sub { + my %params = @_; + my $settings = $params{settings}; + + $settings->formatter->field(formatter => $settings->formatter->qvf ? 'QVF' : 'Test2') + unless defined $settings->formatter->formatter; + + $settings->formatter->field(show_job_launch => 1) + if $settings->display->verbose > 0; + + if ($settings->display->verbose > 1) { + $settings->formatter->field(show_job_info => 1); + $settings->formatter->field(show_run_info => 1); + } + }; +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Display - Display options for Yath. + +=head1 DESCRIPTION + +This is where display options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Finder.pm b/libold2/App/Yath/Options/Finder.pm new file mode 100644 index 000000000..58557d346 --- /dev/null +++ b/libold2/App/Yath/Options/Finder.pm @@ -0,0 +1,391 @@ +package App::Yath::Options::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +my %RERUN_MODES = ( + all => "Re-Run all tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + failed => "Re-Run failed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + retried => "Re-Run retried tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + passed => "Re-Run passed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + missed => "Run missed tests from a previously aborted/stopped run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", +); + +option_group {prefix => 'finder', category => "Finder Options", builds => 'Test2::Harness::Finder'} => sub { + option finder => ( + type => 's', + default => 'Test2::Harness::Finder', + description => 'Specify what Finder subclass to use when searching for files/processing the file list. Use the "+" prefix to specify a fully qualified namespace, otherwise Test2::Harness::Finder::XXX namespace is assumed.', + long_examples => [' MyFinder', ' +Test2::Harness::Finder::MyFinder'], + pre_command => 1, + adds_options => 1, + pre_process => \&finder_pre_process, + action => \&finder_action, + + builds => undef, # This option is not for the build + ); + + option extension => ( + field => 'extensions', + type => 'm', + alt => ['ext'], + description => 'Specify valid test filename extensions, default: t and t2', + ); + + option search => ( + type => 'm', + + description => 'List of tests and test directories to use instead of the default search paths. Typically these can simply be listed as command line arguments without the --search prefix.', + ); + + option no_long => ( + description => "Do not run tests that have their duration flag set to 'LONG'", + ); + + option only_long => ( + description => "Only run tests that have their duration flag set to 'LONG'", + ); + + option show_changed_files => ( + description => "Print a list of changed files if any are found", + applicable => \&changes_applicable, + ); + + option changed_only => ( + description => "Only search for tests for changed files (Requires a coverage data source, also requires a list of changes either from the --changed option, or a plugin that implements changed_files() or changed_diff())", + applicable => \&changes_applicable, + ); + + option rerun => ( + type => 'd', + description => "Re-Run tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ); + + option rerun_plugin => ( + type => 'm', + description => "What plugin(s) should be used for rerun (will fallback to other plugins if the listed ones decline the value, this is just used ot set an order of priority)", + long_examples => [' Foo', ' +App::Yath::Plugin::Foo'], + ); + + option rerun_modes => ( + alt => ['rerun-mode'], + type => 'm', + description => "Pick which test categories to run", + long_examples => [' failed,missed,...', map {" $_"} sort keys %RERUN_MODES], + ); + + for my $mode (keys %RERUN_MODES) { + option "rerun_$mode" => ( + type => 'd', + description => $RERUN_MODES{$mode}, + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ignore_for_build => 1, + ); + } + + option changed => ( + type => 'm', + description => "Specify one or more files as having been changed.", + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_file => ( + type => 'm', + description => 'Specify one or more files to ignore when looking at changes', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_pattern => ( + type => 'm', + description => 'Ignore files matching this pattern when looking for changes. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_filter_file => ( + type => 'm', + description => 'Specify one or more files to check for changes. Changes to other files will be ignored', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_filter_pattern => ( + type => 'm', + description => 'Specify a pattern for change checking. When only running tests for changed files this will limit which files are checked for changes. Only files that match this pattern will be checked. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_diff => ( + type => 's', + description => "Path to a diff file that should be used to find changed files for use with --changed-only. This must be in the same format as `git diff -W --minimal -U1000000`", + long_examples => [' path/to/diff.diff'], + applicable => \&changes_applicable, + ); + + option changes_plugin => ( + type => 's', + description => "What plugin should be used to detect changed files.", + long_examples => [' Git', ' +App::Yath::Plugin::Git'], + applicable => \&changes_applicable, + ); + + option changes_include_whitespace => ( + type => 'b', + description => "Include changed lines that are whitespace only (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_nonsub => ( + type => 'b', + description => "Exclude changes outside of subroutines (perl files only) (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_loads => ( + type => 'b', + description => "Exclude coverage tests which only load changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_opens => ( + type => 'b', + description => "Exclude coverage tests which only open() changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option maybe_durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option durations_threshold => ( + alt => ['Dt'], + type => 's', + default => undef, + description => "Only fetch duration data if running at least this number of tests. Default (-j value + 1)" + ); + + option exclude_file => ( + field => 'exclude_files', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a file from testing", + ); + + option exclude_pattern => ( + field => 'exclude_patterns', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a pattern from testing, matched using m/\$PATTERN/", + ); + + option exclude_list => ( + field => 'exclude_lists', + type => 'm', + + long_examples => [' file.txt', ' http://example.com/exclusions.txt'], + short_examples => [' file.txt', ' http://example.com/exclusions.txt'], + + description => "Point at a file or url which has a new line separated list of test file names to exclude from testing. Starting a line with a '#' will comment it out (for compatibility with Test2::Aggregate list files).", + ); + + option default_search => ( + type => 'm', + + description => "Specify the default file/dir search. defaults to './t', './t2', and 'test.pl'. The default search is only used if no files were specified at the command line", + ); + + option default_at_search => ( + type => 'm', + + description => "Specify the default file/dir search when 'AUTHOR_TESTING' is set. Defaults to './xt'. The default AT search is only used if no files were specified at the command line", + ); + + post \&_post_process; +}; + +sub _post_process { + my %params = @_; + my $settings = $params{settings}; + my $options = $params{options}; + + my $finder = $settings->finder; + + my $rerun = $finder->rerun; + + for my $mode (sort keys %RERUN_MODES) { + my $val = $finder->remove_field("rerun_$mode") or next; + + push @{$finder->rerun_modes} => $mode; + + next if $val eq '1'; + + $rerun //= $val; + $rerun = $val if $rerun eq '1'; + + die "Multiple runs specified for rerun ($val and $rerun). Please pick one.\n" if $val ne $rerun; + } + + $finder->field(rerun => $rerun); + + my (%seen, @keep); + for my $mode (sort map { split /,/ } @{$finder->rerun_modes}) { + next if $seen{$mode}++; + die "Invalid rerun-mode '$mode'.\n" unless $RERUN_MODES{$mode}; + push @keep => $mode; + } + push @keep => 'all' unless @keep; + + @{$finder->rerun_modes} = @keep; + + if (!defined($settings->finder->durations_threshold)) { + if ($settings->check_prefix('runner')) { + my $jc = $settings->runner->job_count // 1; + $settings->finder->field(durations_threshold => $jc + 1); + } + + $settings->finder->field(durations_threshold => 1); + } + + $settings->finder->field(default_search => ['./t', './t2', 'test.pl']) + unless $settings->finder->default_search && @{$settings->finder->default_search}; + + $settings->finder->field(default_at_search => ['./xt']) + unless $settings->finder->default_at_search && @{$settings->finder->default_at_search}; + + @{$settings->finder->extensions} = ('t', 't2') + unless @{$settings->finder->extensions}; + + s/^\.//g for @{$settings->finder->extensions}; +} + +sub normalize_class { + my ($class) = @_; + + $class = "Test2::Harness::Finder::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + require $file; + + return $class; +} + +sub finder_pre_process { + my %params = @_; + + my $class = $params{val} or return; + + $class = normalize_class($class); + + return unless $class->can('options'); + + $params{options}->include_from($class); +} + +sub finder_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my $class = $norm; + + $class = normalize_class($class); + + if ($class->can('options')) { + $options->populate_pre_defaults(); + $options->populate_cmd_defaults(); + } + + $class->munge_settings($settings, $options) if $class->can('munge_settings'); + + $handler->($slot, $class); +} + +sub changes_applicable { + my ($option, $options) = @_; + + # Cannot use this options with projects + return 0 if $options->command_class && $options->command_class->isa('App::Yath::Command::projects'); + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Finder - Finder options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for discovering test files are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Logging.pm b/libold2/App/Yath/Options/Logging.pm new file mode 100644 index 000000000..377ea2012 --- /dev/null +++ b/libold2/App/Yath/Options/Logging.pm @@ -0,0 +1,169 @@ +package App::Yath::Options::Logging; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX qw/strftime/; +use Test2::Harness::Util qw/clean_path/; +use File::Spec; + +use App::Yath::Options; + +option_group {prefix => 'logging', category => "Logging Options"} => sub { + option log => ( + short => 'L', + description => 'Turn on logging', + ); + + option log_file_format => ( + alt => ['lff'], + type => 's', + + env_vars => [qw/YATH_LOG_FILE_FORMAT TEST2_HARNESS_LOG_FORMAT/], + default => sub { '%!P%Y-%m-%d_%H:%M:%S_%!U.jsonl' }, + + description => 'Specify the format for automatically-generated log files. Overridden by --log-file, if given. This option implies -L (Default: \$YATH_LOG_FILE_FORMAT, if that is set, or else "%!P%Y-%m-%d~%H:%M:%S~%!U~%!p.jsonl"). This is a string in which percent-escape sequences will be replaced as per POSIX::strftime. The following special escape sequences are also replaced: (%!P : Project name followed by a ~, if a project is defined, otherwise empty string) (%!U : the unique test run ID) (%!p : the process ID) (%!S : the number of seconds since local midnight UTC)', + + ); + + option bzip2 => ( + short => 'B', + alt => ['bz2', 'bzip2_log'], + description => 'Use bzip2 compression when writing the log. This option implies -L. The .bz2 prefix is added to log file name for you', + ); + + option gzip => ( + short => 'G', + alt => ['gz', 'gzip_log'], + description => 'Use gzip compression when writing the log. This option implies -L. The .gz prefix is added to log file name for you', + ); + + option log_dir => ( + type => 's', + normalize => \&clean_path, + description => 'Specify a log directory. Will fall back to the system temp dir.', + ); + + option log_file => ( + short => 'F', + type => 's', + normalize => \&clean_path, + description => "Specify the name of the log file. This option implies -L.", + ); + + post \&post_process; +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + my $logging = $settings->logging; + + die "You cannot specify both bzip2-log and gzip-log\n" if $logging->bzip2 && $logging->gzip; + + return unless $logging->log || $logging->bzip2 || $logging->gzip || $logging->log_file; + + # We want to keep the log and put it in a findable location + $logging->field(log => 1); + + unless ($logging->log_file) { + my $log_dir = $logging->log_dir // ($settings->check_prefix('workspace') ? $settings->workspace->tmp_dir : File::Spec->tmpdir); + + mkdir($log_dir) or die "Could not create dir '$log_dir': $!" + unless -d $log_dir; + + my $format = $logging->log_file_format; + my $filename = expand_log_file_format($format, $settings); + $logging->field(log_file => clean_path(File::Spec->catfile($log_dir, $filename))); + } + + my $log_file = $logging->log_file; + $log_file =~ s{/+$}{}g; + $log_file =~ s/\.(gz|bz2)$//; + $log_file =~ s/\.jsonl?$//; + $log_file .= "\.jsonl"; + $log_file .= "\.bz2" if $logging->bzip2; + $log_file .= "\.gz" if $logging->gzip; + $logging->field(log_file => $log_file); +} + +sub time_for_strftime { time() } + +sub expand_log_file_format { + my ($pattern, $settings) = @_; + my $before = $pattern; + $pattern =~ s{%!(\w)}{expand($1, $settings)}ge; + my $res = strftime($pattern, localtime(time_for_strftime())); + return $res; +} + +sub expand { + my ($letter, $settings) = @_; + # This could be driven by a hash, but for now if-else is easiest + if ($letter eq "U") { return $settings->run->run_id } + elsif ($letter eq "p") { return $$ } + elsif ($letter eq "P") { + my $project = $settings->harness->project // return ""; + return $project . "~"; + } + elsif ($letter eq "S") { + # Number of seconds since midnight + my ($s, $m, $h) = (localtime(time_for_strftime()))[0, 1, 2]; + return sprintf("%05d", $s + 60 * $m + 3600 * $h); + } + else { + # unrecognized `%!x` expansion. Should we warn? Die? + return "%!$letter"; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Logging - Logging options for yath + +=head1 DESCRIPTION + +This is where the command line options for logging are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Persist.pm b/libold2/App/Yath/Options/Persist.pm new file mode 100644 index 000000000..c73e306a7 --- /dev/null +++ b/libold2/App/Yath/Options/Persist.pm @@ -0,0 +1,68 @@ +package App::Yath::Options::Persist; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; +use Test2::Harness::Util qw/clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option daemon => ( + description => 'Start the runner as a daemon (Default: True)', + default => 1, + ); +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Persist - Persistent Runner options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the persistent runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/PreCommand.pm b/libold2/App/Yath/Options/PreCommand.pm new file mode 100644 index 000000000..a99c8f387 --- /dev/null +++ b/libold2/App/Yath/Options/PreCommand.pm @@ -0,0 +1,177 @@ +package App::Yath::Options::PreCommand; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/mod2file clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'harness', pre_command => 1} => sub { + option plugins => ( + type => 'm', + short => 'p', + alt => ['plugin'], + + category => 'Plugins', + long_examples => [' PLUGIN', ' +App::Yath::Plugin::PLUGIN', ' PLUGIN=arg1,arg2,...'], + short_examples => ['PLUGIN'], + description => 'Load a yath plugin.', + + action => \&plugin_action, + ); + + option no_scan_plugins => ( + type => 'b', + + category => 'Plugins', + description => 'Normally yath scans for and loads all App::Yath::Plugin::* modules in order to bring in command-line options they may provide. This flag will disable that. This is useful if you have a naughty plugin that is loading other modules when it should not.', + ); + + option project => ( + type => 's', + alt => ['project-name'], + category => 'Environment', + description => 'This lets you provide a label for your current project/codebase. This is best used in a .yath.rc file. This is necessary for a persistent runner.', + ); + + option persist_dir => ( + type => 's', + category => 'Environment', + description => 'Where to find persistence files.', + normalize => \&clean_path, + ); + + option persist_file => ( + type => 's', + category => 'Environment', + alt => ['pfile'], + normalize => \&clean_path, + description => "Where to find the persistence file. The default is /{system-tempdir}/project-yath-persist.json. If no project is specified then it will fall back to the current directory. If the current directory is not writable it will default to /tmp/yath-persist.json which limits you to one persistent runner on your system.", + ); + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + normalize => \&normalize_dev_libs, + action => \&dev_libs_action, + ); + + post \&post_process; +}; + +sub plugin_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my ($class, $args) = split /=/, $norm, 2; + $args = [split ',', $args] if $args; + + $class = "App::Yath::Plugin::$class" + unless $class =~ s/^\+//; + + return if grep { $class eq (ref($_) || $_) } @{$settings->harness->plugins}; + + my $file = mod2file($class); + require $file; + + $options->include_from($class) if $class->can('options'); + + my $plugin = $class->can('new') ? $class->new(@{$args // []}) : $class; + + $handler->($slot, $plugin); +} + +sub normalize_dev_libs { + my $val = shift; + + return $val if $val eq '1'; + + return clean_path($val); +} + +sub dev_libs_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my %seen = map { $_ => 1 } @{$$slot}; + + my @new = grep { !$seen{$_}++ } ($norm eq '1') ? (map { clean_path($_) } 'lib', 'blib/lib', 'blib/arch') : ($norm); + + return unless @new; + + warn <<" EOT" for @new; +dev-lib '$_' added to \@INC late, it is possible some yath libraries were already loaded from other paths. +(Maybe you need to move the -D or --dev-lib argument(s) to be earlier in your command line or config file?) + EOT + + unshift @INC => @new; + unshift @{$$slot} => @new; +} + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->harness->field(persist_file => find_pfile($settings, vivify => 1, no_checks => 1)) + unless defined $settings->harness->persist_file; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::PreCommand - Options for yath before command is specified. + +=head1 DESCRIPTION + +This is qhere many pe-commnd options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Run.pm b/libold2/App/Yath/Options/Run.pm new file mode 100644 index 000000000..8d735bb4f --- /dev/null +++ b/libold2/App/Yath/Options/Run.pm @@ -0,0 +1,231 @@ +package App::Yath::Options::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Options; + +option_group {prefix => 'run', category => "Run Options", builds => 'Test2::Harness::Run'} => sub { + post \&post_process; + + option link => ( + field => 'links', + type => 'm', + long_examples => [ + " 'https://travis.work/builds/42'", + " 'https://jenkins.work/job/42'", + " 'https://buildbot.work/builders/foo/builds/42'", + ], + description => "Provide one or more links people can follow to see more about this run." + ); + + option test_args => ( + type => 'm', + description => 'Arguments to pass in as @ARGV for all tests that are run. These can be provided easier using the \'::\' argument separator.' + ); + + option input => ( + type => 's', + description => 'Input string to be used as standard input for ALL tests. See also: --input-file', + ); + + option input_file => ( + type => 's', + description => 'Use the specified file as standard input to ALL tests', + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + die "Input file not found: $norm\n" unless -f $norm; + if ($settings->run->input) { + warn "Input file is overriding another source of input.\n"; + $settings->run->field(input => undef); + } + + $handler->($slot, $norm); + }, + ); + + option dbi_profiling => ( + type => 'b', + description => "Use Test2::Plugin::DBIProfile to collect database profiling data", + ); + + option author_testing => ( + short => 'A', + description => 'This will set the AUTHOR_TESTING environment to true', + ); + + option use_stream => ( + name => 'stream', + description => "Use the stream formatter (default is on)", + default => 1, + ); + + option tap => ( + field => 'use_stream', + alt => ['TAP', '--no-stream'], + normalize => sub { $_[0] ? 0 : 1 }, + description => "The TAP format is lossy and clunky. Test2::Harness normally uses a newer streaming format to receive test results. There are old/legacy tests where this causes problems, in which case setting --TAP or --no-stream can help." + ); + + option fields => ( + type => 'm', + short => 'f', + long_examples => [' name:details', ' JSON_STRING'], + short_examples => [' name:details', ' JSON_STRING'], + description => "Add custom data to the harness run", + action => \&fields_action, + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables to set when each test is run.', + ); + + option run_id => ( + alt => ['id'], + description => 'Set a specific run-id. (Default: a UUID)', + default => \&gen_uuid, + ); + + option load => ( + type => 'm', + short => 'm', + alt => ['load-module'], + description => 'Load a module in each test (after fork). The "import" method is not called.', + ); + + option load_import => ( + type => 'H', + short => 'M', + alt => ['loadim'], + + long_examples => [' Module', ' Module=import_arg1,arg2,...'], + short_examples => [' Module', ' Module=import_arg1,arg2,...'], + + description => 'Load a module in each test (after fork). Import is called.', + ); + + option event_uuids => ( + default => 1, + alt => ['uuids'], + description => 'Use Test2::Plugin::UUID inside tests (default: on)', + ); + + option mem_usage => ( + default => 1, + description => 'Use Test2::Plugin::MemUsage inside tests (default: on)', + ); + + option io_events => ( + default => 0, + description => 'Use Test2::Plugin::IOEvents inside tests to turn all prints into test2 events (default: off)', + ); + + option retry => ( + default => 0, + short => 'r', + type => 's', + description => 'Run any jobs that failed a second time. NOTE: --retry=1 means failing tests will be attempted twice!', + ); + + option retry_isolated => ( + default => 0, + alt => ['retry-iso'], + type => 'b', + description => 'If true then any job retries will be done in isolation (as though -j1 was set)', + ); +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->run->env_vars->{AUTHOR_TESTING} = 1 if $settings->run->author_testing; + + if ($settings->run->dbi_profiling) { + eval { require Test2::Plugin::DBIProfile; 1 } or die "Could not enable DBI profiling, could not load 'Test2::Plugin::DBIProfile': $@"; + push @{$settings->run->load_import->{'@'}} => 'Test2::Plugin::DBIProfile'; + $settings->run->load_import->{'Test2::Plugin::DBIProfile'} = []; + } +} + +sub fields_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my $fields = ${$slot} //= []; + + if ($norm =~ m/^{/) { + my $field = {}; + my $ok = eval { $field = Test2::Harness::Util::JSON::decode_json($norm); 1 }; + chomp(my $error = $@ // ''); + + die "Error parsing field specification '$field': $error\n" unless $ok; + die "Fields must have a 'name' key (error in '$raw')\n" unless $field->{name}; + die "Fields must habe a 'details' key (error in '$raw')\n" unless $field->{details}; + + return push @$fields => $field; + } + elsif ($norm =~ m/([^:]+):([^:]+)/) { + return push @$fields => {name => $1, details => $2}; + } + + die "'$raw' is not a valid field specification.\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Run - Run options for Yath. + +=head1 DESCRIPTION + +This is where command lines options for a single test run are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Runner.pm b/libold2/App/Yath/Options/Runner.pm new file mode 100644 index 000000000..e8bb5feff --- /dev/null +++ b/libold2/App/Yath/Options/Runner.pm @@ -0,0 +1,362 @@ +package App::Yath::Options::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use List::Util qw/min/; +use Test2::Util qw/IS_WIN32/; +use App::Yath::Util qw/find_in_updir/; +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use File::Spec; + +use App::Yath::Options; + +my $DEFAULT_COVER_ARGS = '-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option use_fork => ( + alt => ['fork'], + description => "(default: on, except on windows) Normally tests are run by forking, which allows for features like preloading. This will turn off the behavior globally (which is not compatible with preloading). This is slower, it is better to tag misbehaving tests with the '# HARNESS-NO-PRELOAD' comment in their header to disable forking only for those tests.", + env_vars => [qw/!T2_NO_FORK T2_HARNESS_FORK !T2_HARNESS_NO_FORK YATH_FORK !YATH_NO_FORK/], + default => sub { + return 0 if IS_WIN32; + return 1; + }, + ); + + option abort_on_bail => ( + type => 'b', + default => 1, + description => "Abort all testing if a bail-out is encountered (default: on)", + ); + + option use_timeout => ( + alt => ['timeout'], + description => "(default: on) Enable/disable timeouts", + default => 1, + ); + + option shared_jobs_config => ( + type => 's', + description => 'Where to look for a shared slot config file. If a filename with no path is provided yath will search the current and all parent directories for the name.', + default => '.sharedjobslots.yml', + long_examples => [ ' .sharedjobslots.yml', ' relative/path/.sharedjobslots.yml', ' /absolute/path/.sharedjobslots.yml' ], + ); + + post \&jobs_post_process; + option job_count => ( + type => 's', + short => 'j', + alt => ['jobs'], + description => 'Set the number of concurrent jobs to run. Add a :# if you also wish to designate multiple slots per test. 8:2 means 8 slots, but each test gets 2 slots, so 4 tests run concurrently. Tests can find their concurrency assignemnt in the "T2_HARNESS_MY_JOB_CONCURRENCY" environment variable.', + env_vars => [qw/YATH_JOB_COUNT T2_HARNESS_JOB_COUNT HARNESS_JOB_COUNT/], + clear_env_vars => 1, + long_examples => [' 4', ' 8:2'], + short_examples => ['4', '8:2'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($jobs, $slots) = split /:/, $norm; + + $$slot = $jobs; + + $settings->runner->slots_per_job($slots) if defined $slots; + + fix_job_resources($settings); + }, + ); + + option slots_per_job => ( + type => 's', + short => 'x', + description => "This sets the number of slots each job will use (default 1). This is normally set by the ':#' in '-j#:#'.", + env_vars => ['T2_HARNESS_JOB_CONCURRENCY'], + clear_env_vars => 1, + long_examples => [' 2'], + short_examples => ['2'], + ); + + option dump_depmap => ( + type => 'b', + description => "When using staged preload, dump the depmap for each stage as json files", + default => 0, + ); + + option includes => ( + name => 'include', + short => 'I', + type => 'm', + description => "Add a directory to your include paths", + ); + + option resources => ( + name => 'resource', + short => 'R', + type => 'm', + description => "Use a resource module to assign resource assignments to individual tests", + long_examples => [' Port', ' +Test2::Harness::Runner::Resource::Port'], + short_examples => [' Port'], + + normalize => sub { + my $val = shift; + + $val = "Test2::Harness::Runner::Resource::$val" + unless $val =~ s/^\+//; + + return $val; + }, + ); + + option tlib => ( + description => "(Default: off) Include 't/lib' in your module path", + default => 0, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => File::Spec->catdir('t', 'lib'); + }, + ); + + option lib => ( + short => 'l', + description => "(Default: include if it exists) Include 'lib' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => 'lib'; + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option blib => ( + short => 'b', + description => "(Default: include if it exists) Include 'blib/lib' and 'blib/arch' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + push @{$settings->runner->includes} => ( + File::Spec->catdir('blib', 'lib'), + File::Spec->catdir('blib', 'arch'), + ); + + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option unsafe_inc => ( + description => "perl is removing '.' from \@INC as a security concern. This option keeps things from breaking for now.", + env_vars => [qw/PERL_USE_UNSAFE_INC/], + default => 0, + ); + + option preloads => ( + type => 'm', + alt => ['preload'], + short => 'P', + description => 'Preload a module before running tests', + ); + + option preload_threshold => ( + short => 'W', + alt => ['Pt'], + type => 's', + default => 0, + description => "Only do preload if at least N tests are going to be run. In some cases a full preload takes longer than simply running the tests, this lets you specify a minimum number of test jobs that will be run for preload to happen. This has no effect for a persistent runner. The default is 0, and it means always preload." + ); + + option nytprof => ( + type => 'b', + description => "Use Devel::NYTProf on tests. This will set addpid=1 for you. This works with or without fork.", + long_examples => [''], + ); + + post \&cover_post_process; + option cover => ( + type => 'd', + description => "Use Devel::Cover to calculate test coverage. This disables forking. If no args are specified the following are used: $DEFAULT_COVER_ARGS", + long_examples => ['', '=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'], + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = $DEFAULT_COVER_ARGS if $norm eq '1'; + return $$slot = $norm; + }, + ); + + option switch => ( + field => 'switches', + short => 'S', + type => 'm', + description => 'Pass the specified switch to perl for each test. This is not compatible with preload.', + ); + + option event_timeout => ( + alt => ['et'], + + type => 's', + default => 60, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Kill test if no output is received within timeout period. (Default: 60 seconds). Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis. This prevents a hung test from running forever.', + ); + + option post_exit_timeout => ( + alt => ['pet'], + + type => 's', + default => 15, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Stop waiting post-exit after the timeout period. (Default: 15 seconds) Some tests fork and allow the parent to exit before writing all their output. If Test2::Harness detects an incomplete plan after the test exits it will monitor for more events until the timeout period. Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis.' + ); + + option runner_id => ( + type => 's', + default => sub { gen_uuid() }, + description => 'Runner ID (usually a generated uuid)', + ); +}; + +sub jobs_post_process { + my %params = @_; + my $settings = $params{settings}; + + my $runner = $settings->runner or return; + + fix_job_resources($settings); + + $ENV{T2_HARNESS_MY_JOB_COUNT} = $runner->job_count; + $ENV{T2_HARNESS_MY_MAX_JOB_CONCURRENCY} = $runner->slots_per_job; +} + +sub fix_job_resources { + my ($settings) = @_; + + my $runner = $settings->runner; + + require Test2::Harness::Runner::Resource::SharedJobSlots::Config; + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + + my %found; + for my $r (@{$runner->resources}) { + require(mod2file($r)); + next unless $r->job_limiter; + $found{$r}++; + } + + if ($sconf && !$found{'Test2::Harness::Runner::Resource::SharedJobSlots'}) { + if (delete $found{'Test2::Harness::Runner::Resource::JobCount'}) { + @{$settings->runner->resources} = grep { $_ ne 'Test2::Harness::Runner::Resource::JobCount' } @{$runner->resources}; + } + + if (!keys %found) { + require Test2::Harness::Runner::Resource::SharedJobSlots; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::SharedJobSlots'; + $found{'Test2::Harness::Runner::Resource::SharedJobSlots'}++; + } + } + elsif (!keys %found) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + if ($found{'Test2::Harness::Runner::Resource::SharedJobSlots'} && $sconf) { + $runner->field(job_count => $sconf->default_slots_per_run || $sconf->max_slots_per_run) if $runner && !$runner->job_count; + $runner->field(slots_per_job => $sconf->default_slots_per_job || $sconf->max_slots_per_job) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "Requested job count ($run_slots) exceeds the system shared limit (" . $sconf->max_slots_per_run . ").\n" + if $run_slots > $sconf->max_slots_per_run; + + die "Requested job concurrency ($job_slots) exceeds the system shared limit (" . $sconf->max_slots_per_job . ").\n" + if $job_slots > $sconf->max_slots_per_job; + } + + $runner->field(job_count => 1) if $runner && !$runner->job_count; + $runner->field(slots_per_job => 1) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "The slots_per_job (set to $job_slots) must not be larger than the job_count (set to $run_slots).\n" if $job_slots > $run_slots; +} + +sub cover_post_process { + my %params = @_; + my $settings = $params{settings}; + + if ($ENV{T2_DEVEL_COVER} && !$settings->runner->cover) { + $settings->runner->field(cover => $ENV{T2_DEVEL_COVER} eq '1' ? $ENV{T2_DEVEL_COVER} : $DEFAULT_COVER_ARGS); + } + + return unless $settings->runner->cover; + + # For nested things + $ENV{T2_NO_FORK} = 1; + $ENV{T2_DEVEL_COVER} = $settings->runner->cover; + $settings->runner->field(use_fork => 0); + + return unless $settings->check_prefix('run'); + push @{$settings->run->load_import->{'@'}} => 'Devel::Cover'; + $settings->run->load_import->{'Devel::Cover'} = [split(/,/, $settings->runner->cover)]; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Runner - Runner options for Yath. + +=head1 DESCRIPTION + +This is where command line options for the runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Options/Workspace.pm b/libold2/App/Yath/Options/Workspace.pm new file mode 100644 index 000000000..752306e66 --- /dev/null +++ b/libold2/App/Yath/Options/Workspace.pm @@ -0,0 +1,115 @@ +package App::Yath::Options::Workspace; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); +use File::Path qw/remove_tree/; +use File::Temp qw/tempdir/; + +use Test2::Harness::Util qw/clean_path chmod_tmp/; + +use App::Yath::Options; + +option_group {prefix => 'workspace', category => "Workspace Options"} => sub { + option tmp_dir => ( + type => 's', + short => 't', + alt => ['tmpdir'], + description => 'Use a specific temp directory (Default: use system temp dir)', + env_vars => [qw/T2_HARNESS_TEMP_DIR YATH_TEMP_DIR TMPDIR TEMPDIR TMP_DIR TEMP_DIR/], + default => sub { File::Spec->tmpdir }, + ); + + option workdir => ( + type => 's', + short => 'w', + description => 'Set the work directory (Default: new temp directory)', + env_vars => [qw/T2_WORKDIR YATH_WORKDIR/], + clear_env_vars => 1, + normalize => \&clean_path, + ); + + option clear => ( + short => 'C', + description => 'Clear the work directory if it is not already empty', + ); + + post sub { + my %params = @_; + my $settings = $params{settings}; + + if (my $workdir = $settings->workspace->workdir) { + if (-d $workdir) { + remove_tree($workdir, {safe => 1, keep_root => 1}) if $settings->workspace->clear; + } + else { + mkdir($workdir) or die "Could not create workdir: $!"; + chmod_tmp($workdir); + } + + return; + } + + my $project = $settings->harness->project; + my $template = join '-' => ( "yath", $$, "XXXXXX"); + + my $tmpdir = tempdir( + $template, + DIR => $settings->workspace->tmp_dir, + CLEANUP => !($settings->debug->keep_dirs || $params{command}->always_keep_dir), + ); + chmod_tmp($tmpdir); + + $settings->workspace->field(workdir => $tmpdir); + }; +}; + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Workspace - Options for specifying the yath work dir. + +=head1 DESCRIPTION + +Options regarding the yath working directory. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin.pm b/libold2/App/Yath/Plugin.pm new file mode 100644 index 000000000..b0c0c583a --- /dev/null +++ b/libold2/App/Yath/Plugin.pm @@ -0,0 +1,180 @@ +package App::Yath::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Plugin'; + +# We do not want this defined by default, but it should be documented +#sub handle_event {} +#sub sort_files {} +#sub sort_files_2 {} + +sub finish {} + +sub finalize {} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin - Base class for yath plugins + +=head1 DESCRIPTION + +This is a base class for yath plugins. Note this class also subclasses +L<Test2::Harness::Plugin>. + +This class holds the methods specific to yath, which is the UI layer. +L<Test2::Harness::Plugin> holds the methods specific to L<Test2::Harness> which +is the backend. + +=head1 SYNOPSIS + + package App::Yath::Plugin::MyPlugin; + + use parent 'App::Yath::Plugin'; + + # ... Define methods + + 1; + + +Then to use it at the command line: + + $ yath -pMyPlugin ... + +=head1 NOTE ON INSTANCE VS CLASS + +None of the plugin base classes provide a C<new()> method. By default plugins +are not instantiated and only the plugin package name is passed around. All +methods are then called on the class. + +If you want your plugin to be instantiated as an object you need only define a +C<new()> method. If this method is defined yath will call it and create an +instance. The instance created will then be used when calling all the methods. + +To pass arguments to the constructor you can use +C<yath -pYourPlugin=arg1,arg2,arg3...>. Your plugin can also define options +using L<App::Yath::Options> which will be dropped into the C<$settings> that +get passed around. + +=head1 METHODS + +B<Note:> See L<Test2::Harness::Plugin> for additional method you can implement/override + +=over 4 + +=item $plugin->handle_event($event, $settings) + +Called for every single event that yath sees. Note that this method is not +defined by default for performance reasons, however it will be called if you +define it. + +=item @sorted = $plugin->sort_files_2(settings => $settings, files => \@unsorted) + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +If this is present then C<sort_files()> will be ignored. + +=item @sorted = $plugin->sort_files(@unsorted) + +B<DEPRECATED> Use C<sort_files_2()> instead. + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +=item $plugin->finish(%args) + +This is what arguments are recieved: + + ( + settings => $settings, # The settings + final_data => $final_data, # See below + pass => $pass ? 1 : 0, # Always a 0 or 1 + tests_seen => $self->{+TESTS_SEEN} // 0, # Integer 0 or greater + asserts_seen => $self->{+ASSERTS_SEEN} // 0, # Integer 0 or greater + ) + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=item $plugin->finalize($settings) + +This is called as late as possible before exit. This is mainly useful for +outputting messages such as "Extra log file written to ..." which are best put +at the end of output. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin/Cover.pm b/libold2/App/Yath/Plugin/Cover.pm new file mode 100644 index 000000000..ef46b9514 --- /dev/null +++ b/libold2/App/Yath/Plugin/Cover.pm @@ -0,0 +1,458 @@ +package App::Yath::Plugin::Cover; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::JSON qw/encode_json stream_json_l/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-aggregator -no_aggregate +metrics +outfile/; + +use App::Yath::Options; + +option_group {prefix => 'cover', category => "Cover Options"} => sub { + post \&post_process; + + option types => ( + alt => ['cover-type'], + type => 'm', + default => sub { [qw/pl pm/] }, + ); + + option dirs => ( + alt => ['cover-dir'], + type => 'm', + default => sub { ['lib'] }, + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + push @$$slot => glob($norm); + }, + ); + + option exclude_private => ( + type => 'b', + default => 0, + description => "", + ); + + option files => ( + type => 'b', + description => "Use Test2::Plugin::Cover to collect coverage data for what files are touched by what tests. Unlike Devel::Cover this has very little performance impact (About 4% difference)", + ); + + option metrics => ( + type => 'b', + description => '', + ); + + option write => ( + type => 'd', + normalize => \&clean_path, + long_examples => ['', '=coverage.jsonl', '=coverage.json'], + description => "Create a json or jsonl file of all coverage data seen during the run (This implies --cover-files).", + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path("coverage.jsonl") if $raw eq '1'; + return $$slot = $norm; + }, + ); + + option aggregator => ( + alt => ['cover-agg'], + type => 's', + long_examples => [' ByTest', ' ByRun', ' +Custom::Aggregator'], + description => 'Choose a custom aggregator subclass', + normalize => sub { + my ($agg) = @_; + return $agg if $agg =~ s/^\+//; + return "Test2::Harness::Log::CoverageAggregator::$agg"; + }, + ); + + option class => ( + type => 's', + description => 'Choose a Test2::Plugin::Cover subclass', + default => 'Test2::Plugin::Cover', + ); + + option manager => ( + type => 's', + description => "Coverage 'from' manager to use when coverage data does not provide one", + long_examples => [ ' My::Coverage::Manager'], + applicable => \&changes_applicable, + ); + + option from_type => ( + type => 's', + description => 'File type for coverage source. Usually it can be detected, but when it cannot be you should specify. "json" is old style single-blob coverage data, "jsonl" is the new by-test style, "log" is a logfile from a previous run.', + long_examples => [' json', ' jsonl', ' log' ], + ); + + option maybe_from_type => ( + type => 's', + 'description' => 'Same as "from_type" but for "maybe_from". Defaults to "from_type" if that is specified, otherwise auto-detect', + long_examples => [' json', ' jsonl', ' log' ], + ); + + option from => ( + type => 's', + description => "This can be a test log, a coverage dump (old style json or new jsonl format), or a url to any of the previous. Tests will not be run if the file/url is invalid.", + long_examples => [' path/to/log.jsonl', ' http://example.com/coverage', ' path/to/coverage.jsonl'] + ); + + option maybe_from => ( + type => 's', + description => "This can be a test log, a coverage dump (old style json or new jsonl format), or a url to any of the previous. Tests will coninue if even if the coverage file/url is invalid.", + long_examples => [' path/to/log.jsonl', ' http://example.com/coverage', ' path/to/coverage.jsonl'] + ); +}; + +sub changes_applicable { + my ($option, $options) = @_; + + # Cannot use this options with projects + return 0 if $options->command_class && $options->command_class->isa('App::Yath::Command::projects'); + return 1; +} + +sub spawn_args { + my $self = shift; + my ($settings) = @_; + + return () unless $settings->cover->files || $settings->cover->metrics || $settings->cover->write; + + my $class = $settings->cover->class; + return ('-M' . $class . '=disabled,1'); +} + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + my $cover = $settings->cover; + + if ($cover->files || $cover->write || $cover->metrics) { + my $cover_class = $cover->class // 'Test2::Plugin::Cover'; + + eval { require(mod2file($cover_class)); 1 } or die "Could not enable file coverage, could not load '$cover_class': $@"; + push @{$settings->run->load_import->{'@'}} => $cover_class; + $settings->run->load_import->{$cover_class} = []; + } +} + +sub annotate_event { + my $self = shift; + return if $self->{+NO_AGGREGATE}; + my ($e, $settings) = @_; + + unless ($self->{+AGGREGATOR}) { + my $do_cover = $settings->cover->files; + my $file = $settings->cover->write; + my $metrics = $settings->cover->metrics; + + unless ($file || $metrics || $do_cover) { + $self->{+NO_AGGREGATE} = 1; + return; + } + + my $agg = $settings->cover->aggregator; + if (!$agg) { + if ($file) { + if ($file =~ m/\.json$/) { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByRun'; + } + elsif ($file =~ m/\.jsonl$/) { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + } + else { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + } + + my $encode; + if ($agg eq 'Test2::Harness::Log::CoverageAggregator::ByRun') { + $encode = \&encode_json; + } + elsif ($agg eq 'Test2::Harness::Log::CoverageAggregator::ByTest') { + $encode = sub { encode_json($_[0]) . "\n" }; + } + + require(mod2file($agg)); + $self->{+AGGREGATOR} = $agg->new( + $file ? (file => $file) : (), + $encode ? (encode => $encode) : (), + ); + } + + my $fd = $e->{facet_data}; + + my @out; + + if ($fd->{coverage} || $fd->{harness_job_end} || $fd->{harness_job_start}) { + if (my $list = $self->{+AGGREGATOR}->process_event($e)) { + die "Aggregator flushed without a job end!" unless $fd->{harness_job_end}; + die "Aggregator flushed more than 1 job!" unless @$list == 1; + push @out => (job_coverage => {details => 'Job Coverage', manager => $list->[0]->{manager}, files => $list->[0]->{files}, test => $list->[0]->{test}}); + } + } + + if ($fd->{harness_final}) { + my $cover = $settings->cover; + my $aggregator = $self->{+AGGREGATOR} or return; + my $metrics = $self->metrics($settings) if $cover->metrics; + my $final = $aggregator->finalize(); + + my $percentages = $self->_percentages($metrics); + my $raw = join ", ", map { "$_->[0]: $_->[2]/$_->[1] ($_->[3])" } @$percentages; + my $details = join ", ", map { "$_->[0] $_->[3]" } @$percentages; + + $details = "coverage metrics" unless length $details; + + push @out => ( + run_fields => [ + {name => 'coverage', details => $details, data => $metrics, $raw ? (raw => $raw) : ()}, + ], + ); + + push @out => ( + run_coverage => { + details => 'Run Coverage', + files => $final->[0]->{files}, + testmeta => $final->[0]->{testmeta}, + }, + ) if $final && @$final; + } + + return @out; +} + +sub metrics { + my $self = shift; + my ($settings) = @_; + + my $cover = $settings->cover; + + return unless $cover->metrics; + + my $aggregator = $self->{+AGGREGATOR}; + + return $self->{+METRICS} //= $aggregator->build_metrics( + dirs => $cover->dirs, + types => $cover->types, + exclude_private => $cover->exclude_private, + ); +} + +sub _percentages { + my $self = shift; + my ($metrics) = @_; + + return unless $metrics; + + my @out; + + for my $metric (sort keys %$metrics) { + next if $metric eq 'untested'; + my $data = $metrics->{$metric} or next; + my ($total, $tested) = @{$data}{qw/total tested/}; + push @out => [$metric, $total, $tested, $total ? (int(($tested / $total) * 100) . '%') : '100%']; + } + + return \@out; +} + +sub finalize { + my $self = shift; + my ($settings) = @_; + + my $cover = $settings->cover; + my $file = $cover->write; + my $metrics = $cover->metrics; + + return unless $file || $metrics; + print "\nCoverage:\n"; + + my $aggregator = $self->{+AGGREGATOR}; + + if ($metrics) { + my $data = $self->metrics($settings); + + require Term::Table; + my $table = Term::Table->new( + header => [qw/METRIC TOTAL TESTED PERCENTAGE/], + rows => $self->_percentages($data), + ); + print map { "$_\n" } $table->render; + } + + print "Wrote coverage file: $file\n" if $file; + + print "\n"; +} + +sub _deduce_content_type { + my ($path, $type) = @_; + + if ($type) { + if ($type eq 'json') { + return { + content_type => 'application/json', + parser => 'json', + format => $type, + }; + } + elsif ($type eq 'jsonl' || $type eq 'log') { + return { + content_type => 'application/jsonl', + parser => 'jsonl', + format => $type, + }; + } + } + + if ($path =~ m/\.jsonl/) { + return { + content_type => 'application/jsonl', + parser => 'jsonl', + format => undef, + }; + } + + if ($path =~ m/\.json/) { + return { + content_type => 'application/json', + parser => 'json', + format => undef, + }; + } + + return {}; +} + +sub get_coverage_tests { + my $self = shift; + my ($settings, $changes) = @_; + + my $cover = $settings->cover; + my $from = $cover->from; + my $maybe = $cover->maybe_from; + + return unless $from || $maybe; + + if ($maybe) { + my $type_data = $self->_deduce_content_type($maybe, $cover->maybe_from_type); + + my @out; + my $ok = eval { @out = $self->_get_coverage_tests($settings, $changes, $maybe, $type_data); 1 }; + my $err = $@; + return @out if $ok; + warn "Could not get coverage from '$maybe', continuing anyway... error was: $err"; + } + + return $self->_get_coverage_tests($settings, $changes, $from) + if $from; + + return; +} + +sub _get_coverage_tests { + my $self = shift; + my ($settings, $changes, $source, $type_data) = @_; + + my @out; + + stream_json_l( + $source => sub { push @out => $self->coverage_handler($settings, $changes, $type_data, @_) }, + $type_data->{content_type} ? (http_args => [{headers => {'Content-Type' => $type_data->{content_type}}}]) : (), + ); + + return @out; +} + +sub coverage_handler { + my $self = shift; + my ($settings, $changes, $type_data, $set, $res) = @_; + + return unless $set; + + my ($agg, $data); + if (my $fd = $set->{facet_data}) { + if ($data = $fd->{job_coverage}) { + require 'Test2/Harness/Log/CoverageAggregator/ByTest.pm' unless $INC{'Test2/Harness/Log/CoverageAggregator/ByTest.pm'}; + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + elsif($data = $fd->{run_coverage}) { + require 'Test2/Harness/Log/CoverageAggregator/ByRun.pm' unless $INC{'Test2/Harness/Log/CoverageAggregator/ByRun.pm'}; + $agg = 'Test2::Harness::Log::CoverageAggregator::ByRun'; + } + else { + return; + } + } + else { + $data = $set; + $agg = $set->{aggregator} // return; + my $aggfile = mod2file($agg); + require($aggfile) unless $INC{$aggfile}; + } + + return $agg->get_coverage_tests($settings, $changes, $data); +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Cover - Plugin to collect and report basic coverage data + +=head1 DESCRIPTION + +Simple coverage data, file and sub coverage only. Use L<Devel::Cover> if you +want deep coverage stats. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin/Git.pm b/libold2/App/Yath/Plugin/Git.pm new file mode 100644 index 000000000..0974fc723 --- /dev/null +++ b/libold2/App/Yath/Plugin/Git.pm @@ -0,0 +1,208 @@ +package App::Yath::Plugin::Git; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IPC::Cmd qw/can_run/; +use Test2::Harness::Util::IPC qw/run_cmd/; +use parent 'App::Yath::Plugin'; + +use App::Yath::Options; + +option_group {prefix => 'git', category => "Git Options"} => sub { + option change_base => ( + type => 's', + description => "Find files changed by all commits in the current branch from most recent stopping when a commit is found that is also present in the history of the branch/commit specified as the change base.", + long_examples => [" master", " HEAD^", " df22abe4"], + ); +}; + +my $GIT_CMD = can_run('git'); +sub git_cmd { $ENV{GIT_COMMAND} || $GIT_CMD } + +sub git_output { + my $class = shift; + my (@args) = @_; + + my $cmd = $class->git_cmd or return sub {()}; + + my ($rh, $wh, $irh, $iwh); + pipe($rh, $wh) or die "No pipe: $!"; + pipe($irh, $iwh) or die "No pipe: $!"; + my $pid = run_cmd(stderr => $iwh, stdout => $wh, command => [$cmd, @args]); + + close($wh); + close($iwh); + + $rh->blocking(1); + $irh->blocking(0); + + my $waited = 0; + return sub { + my $line = <$rh>; + return $line if defined $line; + + unless ($waited++) { + local $?; + waitpid($pid, 0); + print STDERR <$irh> if $?; + close($irh); + + # Try again + $line = <$rh>; + return $line if defined $line; + } + + close($rh); + return; + }; +} + +sub inject_run_data { + my $class = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + my $long_sha = $ENV{GIT_LONG_SHA}; + my $short_sha = $ENV{GIT_SHORT_SHA}; + my $status = $ENV{GIT_STATUS}; + my $branch = $ENV{GIT_BRANCH}; + + my @sets = ( + [\$long_sha, 'rev-parse', 'HEAD'], + [\$short_sha, 'rev-parse', '--short', 'HEAD'], + [\$status, 'status', '-s'], + [\$branch, 'rev-parse', '--abbrev-ref', 'HEAD'], + ); + + for my $set (@sets) { + my ($var, @args) = @$set; + next if $$var; # Already set + my $output = $class->git_output(@args); + + my @lines; + while (my $line = $output->()) { + push @lines => $line; + } + + chomp($$var = join "\n" => @lines); + } + + return unless $long_sha; + + $meta->{git}->{sha} = $long_sha; + $meta->{git}->{status} = $status if $status; + + if ($branch) { + $meta->{git}->{branch} = $branch; + + my $short = length($branch) > 20 ? substr($branch, 0, 20) : $branch; + + push @$fields => {name => 'git', details => $short, raw => $branch, data => $meta->{git}}; + } + else { + $short_sha ||= substr($long_sha, 0, 16); + push @$fields => {name => 'git', details => $short_sha, raw => $long_sha, data => $meta->{git}}; + } + + return; +} + +sub changed_diff { + my $class = shift; + my ($settings) = @_; + + $class->_changed_diff($settings->git->change_base); +} + +sub _changed_diff { + my $class = shift; + my ($base) = @_; + + my $cmd = $class->git_cmd or return; + + my $from = 'HEAD'; + + if ($base) { + $from .= "^" while system($cmd => 'merge-base', '--is-ancestor', $from, $base); + return $class->_diff_from($from); + } + + my @files = $class->_diff_from($from); + return @files if @files; + + return $class->_diff_from("${from}^"); +} + +sub _diff_from { + my $class = shift; + my ($from) = @_; + my $cmd = $class->git_cmd or return; + + return (line_sub => $class->git_output('diff', '-U1000000', '-W', '--minimal', $from)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Git - Plugin to attach git data to a test run. + +=head1 DESCRIPTION + +This plugin will attach git data to your test logs if any is available. + +=head1 SYNOPSIS + + $ yath test -pGit ... + +=head1 READING THE DATA + +The data is attached to the 'run' entry in the log file. This can be seen +directly in the json data. The data is also easily accessible with +L<Test2::Harness::UI>. + +The data will include the long sha, short sha, branch name, and a brief status. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin/Notify.pm b/libold2/App/Yath/Plugin/Notify.pm new file mode 100644 index 000000000..56b0a9c3c --- /dev/null +++ b/libold2/App/Yath/Plugin/Notify.pm @@ -0,0 +1,631 @@ +package App::Yath::Plugin::Notify; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::JSON qw/encode_json/; +use Test2::Harness::Util qw/mod2file/; + +use Sys::Hostname qw/hostname/; + +use Carp qw/croak confess/; + +use App::Yath::Options; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-final -tries -problems -problem_cids +text_mod +text_mod_handles_events +text_mod_fail/; + +# Notifications only apply to commands which build a run. +sub applicable { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; +} + +option_group {prefix => 'notify', category => "Notification Options", applicable => \&applicable} => sub { + option slack => ( + type => 'm', + description => "Send results to a slack channel and/or user", + long_examples => [" '#foo'", " '\@bar'"], + ); + + option slack_fail => ( + type => 'm', + description => "Send failing results to a slack channel and/or user", + long_examples => [" '#foo'", " '\@bar'"], + ); + + option slack_url => ( + type => 's', + description => "Specify an API endpoint for slack webhook integrations", + long_examples => [" https://hooks.slack.com/..."], + ); + + option slack_owner => ( + type => 'b', + description => "Send slack notifications to the slack channels/users listed in test meta-data when tests fail.", + default => 0, + ); + + option no_batch_slack => ( + type => 'b', + default => 0, + description => 'Usually owner failures are sent as a single batch at the end of testing. Toggle this to send failures as they happen.', + ); + + option email_from => ( + type => 's', + long_examples => [' foo@example.com'], + description => "If any email is sent, this is who it will be from", + default => sub { + my $user = getlogin() || scalar(getpwuid($<)) || $ENV{USER} || 'unknown'; + my $host = hostname() || 'unknown'; + return "${user}\@${host}"; + }, + ); + + option email => ( + type => 'm', + long_examples => [' foo@example.com'], + description => "Email the test results to the specified email address(es)", + ); + + option email_fail => ( + type => 'm', + long_examples => [' foo@example.com'], + description => "Email failing results to the specified email address(es)", + ); + + option email_owner => ( + type => 'b', + description => 'Email the owner of broken tests files upon failure. Add `# HARNESS-META-OWNER foo@example.com` to the top of a test file to give it an owner', + default => 0, + ); + + option no_batch_email => ( + type => 'b', + default => 0, + description => 'Usually owner failures are sent as a single batch at the end of testing. Toggle this to send failures as they happen.', + ); + + option text => ( + type => 's', + alt => ['message', 'msg'], + description => "Add a custom text snippet to email/slack notifications", + ); + + option text_module => ( + type => 's', + alt => ['message_module'], + description => "Use the specified module to generate messages for emails and/or slack.", + ); + + post sub { + my %params = @_; + + my $settings = $params{settings}; + my $options = $params{options}; + + my $set_by_cli = $options->set_by_cli->{notify}; + + # Should we use email? + if (@{$settings->notify->email} || $settings->notify->email_owner) { + $settings->notify->field(email_owner => 1) unless $set_by_cli->{email_owner}; + + # Do we have Email::Stuffer? + eval { require Email::Stuffer; 1 } or die "Cannot use --email-owner without Email::Stuffer, which is not installed.\n"; + + push @{$settings->harness->plugins} => __PACKAGE__->new() unless grep { $_->isa(__PACKAGE__) } @{$settings->harness->plugins}; + } + + my $use_slack = grep { $settings->notify->$_ } qw/slack_url slack_owner/; + $use_slack ||= grep { @{$settings->notify->$_} } qw/slack slack_fail/; + if ($use_slack) { + die "slack url must be provided in order to use slack" unless $settings->notify->slack_url; + + eval { require HTTP::Tiny; 1 } or die "Cannot use slack without HTTP::Tiny which is not installed.\n"; + + die "HTTP::Tiny reports that it does not support SSL, cannot use slack without ssl." + unless HTTP::Tiny::can_ssl(); + + $settings->notify->field(slack_owner => 1) unless $set_by_cli->{slack_owner}; + + push @{$settings->harness->plugins} => __PACKAGE__->new() unless grep { $_->isa(__PACKAGE__) } @{$settings->harness->plugins}; + } + }; +}; + +sub text_mod { + my $self = shift; + my ($settings) = @_; + + croak 'settings is a required argument' unless $settings; + + return $self->{+TEXT_MOD} if exists $self->{+TEXT_MOD}; + + if (my $tm = $settings->notify->text_module) { + my $file = mod2file($tm); + if (eval { require $file; 1 }) { + my $inst = $tm->can('new') ? $tm->new() : $tm; + $self->{+TEXT_MOD_HANDLES_EVENTS} = $inst->can('handle_event') ? 1 : 0; + return $self->{+TEXT_MOD} = $inst; + } + else { + my $err = $@; + warn "Cannot use module '$tm' for notification text generation: $err"; + chomp($self->{+TEXT_MOD_FAIL} = $err); + } + } + + $self->{+TEXT_MOD_HANDLES_EVENTS} = 0; + return $self->{+TEXT_MOD} = undef; +} + +sub handle_event { + my $self = shift; + my ($e, $settings) = @_; + + my $f = $e->facet_data; + + $self->record_problem($f); + + my $tm = $self->text_mod($settings); + if ($tm && $self->{+TEXT_MOD_HANDLES_EVENTS}) { + $tm->handle_event($e, $f, settings => $settings, notify => $self); + } + + return $self->handle_job_end($e, $f, $settings) if $f->{harness_job_end}; + return $self->handle_final($e, $f, $settings) if $f->{harness_final}; + + return; +} + +sub record_problem { + my $self = shift; + my ($f) = @_; + + return unless $self->has_fail_or_error($f); + + my $job_id = $f->{harness}->{job_id}; + my $job_try = $f->{harness}->{job_try} // 0; + + push @{$self->{+PROBLEMS}->{$job_id}->{$job_try}} => $self->prune_subtests($f); +} + +sub has_fail_or_error { + my $self = shift; + my ($f, %params) = @_; + + return 0 if $f->{trace}->{nested} && !$params{allow_nested}; + return 0 if $f->{amnesty} && @{$f->{amnesty}}; + + my $out = 0; + + my $cid = $f->{trace}->{cid}; + $out = 1 if $cid && $self->{+PROBLEM_CIDS}->{$cid} && $f->{info} && @{$f->{info}}; + $out = 1 if $f->{errors} && @{$f->{errors}}; + $out = 1 if $f->{assert} && !$f->{assert}->{pass}; + + $self->{+PROBLEM_CIDS}->{$cid} = 1 if $cid && $out; + + return $out; +} + +sub prune_subtests { + my $self = shift; + my ($f) = @_; + + my $p = $f->{parent} // return $f; + my $c = $p->{children} // return $f; + + return $f unless @$c; + + my $out = {}; + $out->{$_} = $f->{$_} for grep { $f->{$_} } qw/assert about trace errors info harness control/; + $out->{parent} = {%$p, children => [map { $self->prune_subtests($_) } grep { $self->has_fail_or_error($_, allow_nested => 1) } @$c]}; + + return $out; +} + +sub handle_final { + my $self = shift; + my ($e, $f, $settings) = @_; + + $self->{+FINAL} = $e; +} + +sub handle_job_end { + my $self = shift; + my ($e, $f, $settings) = @_; + + return unless $f->{harness_job_end}->{fail}; + + my $job_id = $f->{harness}->{job_id}; + + if ($f->{harness_job_end}->{retry}) { + $self->{+TRIES}->{$job_id}++; + return; + } + + my @args = ($e, $f, $self->{+TRIES}->{$job_id}, $settings); + + $self->send_job_notification_slack(@args); + $self->send_job_notification_email(@args); +} + +sub send_job_notification_slack { + my $self = shift; + + my ($e, $f, $tries, $settings) = @_; + + return unless $settings->notify->no_batch_slack; + + my $tf = Test2::Harness::TestFile->new(file => $f->{harness_job_end}->{abs_file}); + + my @slack; + push @slack => $tf->meta('slack') if $settings->notify->slack_owner; + push @slack => @{$settings->notify->slack_fail}; + + return unless @slack; + + my $text = $self->gen_text(scope => 'job', service => 'slack', settings => $settings, file => $tf, tries => $tries); + + $self->_send_slack($text, $settings, @slack); +} + +sub gen_slack_job_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $tf = $params{file} // croak "'file' is required"; + my $tries = $params{tries} // 0; + + my $host = hostname(); + my $file = $tf->relative; + + return join "\n\n" => grep { $_ } + $settings->notify->text, + "Failed test on $host: '$file'.", + $tries ? ("Test was run " . (1 + $tries) . " time(s).") : (), + join "\n" => map {"> <$_|$_>"} @{$settings->run->links}; +} + +sub _send_slack { + my $self = shift; + my ($text, $settings, @to) = @_; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + for my $dest (@to) { + my $r = $ht->post( + $settings->notify->slack_url, + { + headers => {'content-type' => 'application/json'}, + content => encode_json({channel => $dest, text => $text}), + }, + ); + warn "Failed to send slack message to '$dest'" unless $r->{success}; + } +} + +sub send_job_notification_email { + my $self = shift; + + my ($e, $f, $tries, $settings) = @_; + + return unless $settings->notify->no_batch_email; + + my $tf = Test2::Harness::TestFile->new(file => $f->{harness_job_end}->{abs_file}); + + my @to; + push @to => $tf->meta('owner') if $settings->notify->email_owner; + push @to => @{$settings->notify->email_fail}; + return unless @to; + + my $text = $self->gen_text(scope => 'job', service => 'email', settings => $settings, file => $tf, tries => $tries); + my $subject = "Failed test on " . hostname() . ": '" . $tf->relative . "'."; + + $self->_send_email($subject, $text, $settings, @to); +} + +sub gen_email_job_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $tf = $params{file} // croak "'file' is required"; + my $tries = $params{tries} // 0; + + my $host = hostname(); + my $file = $tf->relative; + + return join "\n\n" => grep { $_ } + $settings->notify->text, + "Failed test on $host: '$file'.", + $tries ? ("Test was run " . (1 + $tries) . " time(s).") : (), + join "\n" => @{$settings->run->links}; +} + +sub _send_email { + my $self = shift; + my ($subject, $text, $settings, @to) = @_; + + my $mail = Email::Stuffer->to(@to); + $mail->from($settings->notify->email_from); + $mail->subject($subject); + + my $rtype = ref($text) // ''; + + if (!$rtype) { + $mail->text_body($text); + } + elsif ($rtype eq 'HASH') { + $mail->text_body($text->{text}) if $text->{text}; + $mail->html_body($text->{html}) if $text->{html}; + } + else { + warn "Invalid text type: '$rtype'"; + } + + eval { $mail->send_or_die; 1 } or warn $@; +} + +sub finish { + my $self = shift; + my %params = @_; + my $settings = $params{settings}; + + my $e = $self->{+FINAL} or return; + my $f = $e->facet_data or return; + my $final = $f->{harness_final} or return; + + $self->send_run_notification_slack($final, $settings); + $self->send_run_notification_email($final, $settings); +} + +sub send_run_notification_slack { + my $self = shift; + my ($final, $settings) = @_; + + return if $settings->notify->no_batch_slack; + + my @to = @{$settings->notify->slack}; + push @to => @{$settings->notify->slack_fail} unless $final->{pass}; + + my $files = ""; + if ($final->{failed}) { + for my $set (@{$final->{failed}}) { + my $file = $set->[1]; + + $files = $files ? "$files\n$file" : $file; + + next unless $settings->notify->slack_owner; + my $tf = Test2::Harness::TestFile->new(file => $file); + push @to => $tf->meta('slack'); + } + } + + return unless @to; + + my $text = $self->gen_text( + scope => 'run', + service => 'slack', + settings => $settings, + final => $final, + files => $files, + ); + + $self->_send_slack($text, $settings, @to); +} + +sub gen_slack_run_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $final = $params{final} // croak "'final' is required"; + my $files = $params{files} // ''; + + my $host = hostname(); + + return join "\n\n" => grep { $_ } ( + $settings->notify->text, + ($final->{pass} ? "Tests passed on $host" : "Tests failed on $host"), + ($files ? $files : ()), + join("\n" => map {"> <$_|$_>"} @{$settings->run->links}), + ); +} + +sub send_run_notification_email { + my $self = shift; + my ($final, $settings) = @_; + + return if $settings->notify->no_batch_email; + + my @to = @{$settings->notify->email}; + push @to => @{$settings->notify->email_fail} unless $final->{pass}; + + my $files = ""; + if ($final->{failed}) { + for my $set (@{$final->{failed}}) { + my $file = $set->[1]; + + $files = $files ? "$files\n$file" : $file; + + next unless $settings->notify->email_owner; + my $tf = Test2::Harness::TestFile->new(file => $file); + push @to => $tf->meta('owner'); + } + } + + return unless @to; + + my $subject = $self->gen_text( + scope => 'run', + service => 'email_subject', + settings => $settings, + final => $final, + files => $files, + ); + + my $text = $self->gen_text( + scope => 'run', + service => 'email', + settings => $settings, + final => $final, + files => $files, + subject => $subject, + ); + + $self->_send_email($subject, $text, $settings, @to); +} + +sub gen_email_subject_run_text { + my $self = shift; + my %params = @_; + + my $final = $params{final} // croak "'final' is required"; + my $host = hostname(); + + return $final->{pass} ? "Tests passed on $host" : "Tests failed on $host"; +} + +sub gen_email_run_text { + my $self = shift; + my %params = @_; + + my $subject = $params{subject} // $self->gen_text(%params, service => 'email_subject'); + my $settings = $params{settings} // croak "'settings' is required"; + my $final = $params{final} // croak "'final' is required"; + my $files = $params{files} // ''; + + return join "\n\n" => grep { $_ } ( + $settings->notify->text, + $subject, + ($files ? $files : ()), + join("\n" => @{$settings->run->links}), + ); +} + +sub gen_text { + my $self = shift; + my %params = @_; + + my $scope = $params{scope} or croak "'scope' is required"; + my $service = $params{service} or croak "'service' is required"; + my $settings = $params{settings} or croak "'settings' is required"; + + my $meth = "gen_${service}_${scope}_text"; + + if (my $tm = $self->text_mod($settings)) { + return $tm->$meth(%params, notify => $self) + if $tm->can($meth); + } + + if ($self->can($meth)) { + my $text = $self->$meth(%params); + + my $mod = $settings->notify->text_module; + $text = <<" EOT" if $self->{+TEXT_MOD_FAIL} && $service !~ m/subject/i; +******************************************************************************* +There was an error loading the text generation module '$mod'. +Because of this error the default notification text has been used. + +The error encountered was: +$self->{+TEXT_MOD_FAIL} +******************************************************************************* + +$text + EOT + + return $text; + } + + confess "No notification text method '$meth'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Notify - Plugin to send email and/or slack notifications + +=head1 DESCRIPTION + +This plugin is used for sending email and/or slack notifications from yath. + +=head1 SYNOPSIS + +=head2 IN A TEST + + #!/usr/bin/perl + use Test2::V0; + # HARNESS-META owner author@example.com + # HARNESS-META slack #slack_channel + # HARNESS-META slack #slack_user + +You can use the C<# HARNESS-META owner EMAIL_ADDRESS> to specify an "owner" +email address. You can use the C<# HARNESS-META slack USER/CHANNEL> to specify +a slack user or channel that owns the test. + +=head2 RUNNING WITH NOTIFICATIONS ENABLED + + $ yath test -pNotify ... + +Also of note, most of the time you can just specify the notification options +you want and the plugin will load as needed as long as C<--no-scan-plugins> was +not specified. + +=head3 EMAIL + + $ yath test --notify-email-owner --notify-email-from user@example.com --notify-email-fail fixer@example.com + +=head3 SLACK + +A slack hooks url is always needed for slack to work. + + $ yath test --notify-slack-url https://hooks.slack.com/... --notify-slack-fail '#foo' --notify-slack-owner + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin/SysInfo.pm b/libold2/App/Yath/Plugin/SysInfo.pm new file mode 100644 index 000000000..56eebd2e4 --- /dev/null +++ b/libold2/App/Yath/Plugin/SysInfo.pm @@ -0,0 +1,115 @@ +package App::Yath::Plugin::SysInfo; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Sys::Hostname qw/hostname/; +use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS/; +use Config qw/%Config/; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-host_short_pattern/; + +sub inject_run_data { + my $self = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + my %data = ( + env => { + user => $ENV{USER}, + shell => $ENV{SHELL}, + term => $ENV{TERM}, + }, + + ipc => { + can_fork => CAN_FORK(), + can_really_fork => CAN_REALLY_FORK(), + can_thread => CAN_THREAD(), + can_sigsys => CAN_SIGSYS(), + }, + ); + + my ($short, $raw) = ('sys', 'system info'); + + if (my $hostname = hostname()) { + $short = undef; + $data{hostname} = $hostname; + $raw = $hostname; + + if (my $pattern = $self->{+HOST_SHORT_PATTERN}) { + if ($hostname =~ /($pattern)/) { + $short = $1; + } + } + + unless ($short) { + $short = $hostname; + $short =~ s/\.[^\.]*$// while length($short) > 18 && $short =~ m/\./; + } + } + + my @fields = qw/uselongdouble use64bitall version use64bitint usemultiplicity osname useperlio useithreads archname/; + @{$data{config}}{@fields} = @Config{@fields}; + + push @$fields => { + name => 'sys', + details => $short, + raw => $raw, + data => \%data, + }; +} + +sub TO_JSON { ref($_[0]) } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::SysInfo - Plugin to attach system information to a run. + +=head1 DESCRIPTION + +This plugin attaches a lot of system information to the yath log. This is +mainly useful if you intend to view the log in L<Test2::Harness::UI>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Plugin/YathUI.pm b/libold2/App/Yath/Plugin/YathUI.pm new file mode 100644 index 000000000..2dd3bea7a --- /dev/null +++ b/libold2/App/Yath/Plugin/YathUI.pm @@ -0,0 +1,362 @@ +package App::Yath::Plugin::YathUI; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Test2::Harness::Util qw/read_file mod2file looks_like_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use App::Yath::Options; +use parent 'App::Yath::Plugin'; + +sub can_log { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Logging'}; + return 0; +} + +sub can_finder { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Finder'}; + return 0; +} + +option_group {prefix => 'yathui', category => "YathUI Options"} => sub { + option url => ( + type => 's', + alt => ['uri'], + description => "Yath-UI url", + long_examples => [" http://my-yath-ui.com/..."], + ); + + option api_key => ( + type => 's', + description => "Yath-UI API key. This is not necessary if your Yath-UI instance is set to single-user" + ); + + option project => ( + type => 's', + description => "The Yath-UI project for your test results", + ); + + option mode => ( + type => 's', + default => 'qvfd', + description => "Set the upload mode (default 'qvfd')", + long_examples => [ + ' summary', + ' qvf', + ' qvfd', + ' complete', + ], + ); + + option retry => ( + type => 'c', + description => "How many times to try an operation before giving up", + default => 0, + ); + + option grace => ( + description => "If yath cannot connect to yath-ui it normally throws an error, use this to make it fail gracefully. You get a warning, but things keep going.", + default => 0, + ); + + option durations => ( + description => "Poll duration data from Yath-UI to help order tests efficiently", + default => 0, + applicable => \&can_finder, + ); + + option coverage => ( + description => "Poll coverage data from Yath-UI to determine what tests should be run for changed files", + default => 0, + applicable => \&can_finder, + ); + +# TODO +# option median_durations => ( +# type => 'b', +# description => "Get median duration data", +# default => 0, +# ); + + option medium_duration => ( + type => 's', + description => "Minimum duration length (seconds) before a test goes from SHORT to MEDIUM", + long_examples => [' 5'], + default => 5, + ); + + option long_duration => ( + type => 's', + description => "Minimum duration length (seconds) before a test goes from MEDIUM to LONG", + long_examples => [' 10'], + default => 10, + ); + + option upload => ( + description => "Upload the log to Yath-UI", + default => 0, + applicable => \&can_log, + ); + + post -1 => sub { + my %params = @_; + + my $settings = $params{settings}; + my $options = $params{options}; + + my $has_finder = $options->included->{'App::Yath::Options::Finder'}; + my $has_logger = $options->included->{'App::Yath::Options::Logging'}; + + my $has_durations = $has_finder && $settings->yathui->durations; + my $has_upload = $has_logger && $settings->yathui->upload; + my $has_coverage = $has_finder && $settings->yathui->coverage; + + return unless $has_durations || $has_upload || $has_coverage; + + my $url = $settings->yathui->url or die "'--yathui-url URL' is required to use durations, coverage, or upload a log"; + my $project = $settings->yathui->project or die "'--yathui-project NAME' is required to use durations, coverage, or upload a log"; + my $grace = $settings->yathui->grace; + + $url =~ s{/+$}{}g; + + if ($has_upload) { + $settings->logging->field(log => 1); + $settings->logging->field(bzip2 => 1); + } + + if ($has_coverage) { + my $curl = join '/' => ($url, 'coverage', $project); + $settings->cover->field(($grace ? 'maybe_from' : 'from'), $curl); + } + + if ($has_durations) { + my $med = $settings->yathui->medium_duration; + my $long = $settings->yathui->long_duration; + + my $durl = join '/' => ($url, 'durations', $project, $med, $long); + $settings->finder->field(($grace ? 'maybe_durations' : 'durations'), $durl); + } + + return; + }; +}; + +sub grab_rerun { + my $this = shift; + my ($rerun, %params) = @_; + + return (0) if $rerun =~ m/\.jsonl(\.gz|\.bz2)?/; + + my $settings = $params{settings}; + my $mode_hash = $params{mode_hash}; + + my $path; + if ($rerun eq '1') { + my $project = $settings->yathui->project or return (0); + my $user = $settings->yathui->user // $ENV{USER}; + + $path = "$project/$user"; + + print "Re-run requested with no paremeters, ${ \__PACKAGE__ } querying YathUI (web request) for last run matching $path...\n"; + + # API Qwerk :-/ + $path .= '/0'; + } + elsif (looks_like_uuid($rerun)) { + $path = "$rerun"; + print "Re-run requested with UUID, ${ \__PACKAGE__ } querying YathUI (web request) for matching run, or latest run from project or user matching the UUID\n"; + } + else { + return (0); + } + + $path = "rerun/$path"; + + my ($ok, $res, $data) = $this->_request($settings, $path, {json => 1}); + + if (!$ok) { + print "Error getting a re-run data from yathui: $data...\n"; + return (1); + } + + return (1, $data); +} + +sub _request { + my $this = shift; + my ($settings, $path, $payload) = @_; + + my $url = $settings->yathui->url; + $url =~ s{/+$}{}g; + $url = join "/" => ($url, $path); + + my %fields; + + for my $field (qw/project api_key mode/) { + my $val = $settings->yathui->field($field) or next; + $fields{$field} = $val; + } + + require HTTP::Tiny; + eval { require HTTP::Tiny::Multipart; 1 } or die "To use --yathui-* you must install HTTP::Tiny::Multipart.\n"; + + my $res; + for (0 .. $settings->yathui->retry) { + my $http = HTTP::Tiny->new; + $res = $http->post_multipart( + $url => { + headers => {'Content-Type' => 'application/json'}, + %fields, + %$payload, + }, + ); + + next unless $res; + last if $res->{status} eq '200'; + } + + my ($ok, $msg); + if ($res && $res->{status} eq '200') { + my $data; + $ok = eval { $data = decode_json($res->{content}); 1 }; + if ($ok) { + return (1, $res, $data); + } + else { + $msg = $@; + } + } + else { + if ($res) { + $msg = "Server responded with " . $res->{status} . ":\n" . ($res->{content} // 'NO CONTENT'); + } + else { + $msg = "Failed to upload yathui log, no response object"; + } + } + + return (0, $res, $msg); +} + +sub finish { + my $this = shift; + my %params = @_; + + my $settings = $params{settings}; + + return unless $settings->yathui->upload; + + my $log_file = $settings->logging->log_file; + my ($filename) = reverse File::Spec->splitpath($log_file); + + my ($ok, $res, $data) = $this->_request( + 'upload', { + log_file => { + filename => $filename, + content => read_file($log_file, no_decompress => 1), + content_type => 'application/x-bzip2', + }, + + action => 'Upload Log', + json => 1, + } + ); + + die "Error connecting to YathUI: $data\n" + unless $ok; + + my $msg; + if ($data->{errors} && @{$data->{errors}}) { + $ok = 0; + $msg = join "\n" => (@{$data->{errors}}); + } + elsif ($data->{messages}) { + $ok = 1; + + my $url = $settings->yathui->url; + $url =~ s{/+$}{}g; + + $msg = join "\n" => ( + @{$data->{messages}}, + $data->{run_id} ? ("YathUI run url: " . join '/' => ($url, 'run', $data->{run_id})) : (), + ); + } + else { + $ok = 0; + $msg = "No messages recieved"; + } + + chomp($msg); + $msg = "YathUI Upload: $msg"; + if ($ok) { + print "\n$msg\n"; + } + else { + if ($settings->yathui->grace) { + warn $msg; + } + else { + die $msg; + } + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::YathUI - Plugin to interact with a YathUI server + +=head1 DESCRIPTION + +If you have a Yath-UI L<Test2::Harness::UI> server, you can use this module to +have yath automatically upload logs or retrieve durations data + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Tester.pm b/libold2/App/Yath/Tester.pm new file mode 100644 index 000000000..33045c4bc --- /dev/null +++ b/libold2/App/Yath/Tester.pm @@ -0,0 +1,451 @@ +package App::Yath::Tester; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::API qw/context run_subtest/; +use Test2::Tools::Compare qw/is/; + +use Carp qw/croak/; +use File::Spec; +use File::Temp qw/tempfile tempdir/; +use POSIX; +use Fcntl qw/SEEK_CUR/; + +use App::Yath::Util qw/find_yath/; +use Test2::Harness::Util qw/clean_path apply_encoding/; +use Test2::Harness::Util::IPC qw/run_cmd/; +use Test2::Harness::Util::File::JSONL; + +use Importer Importer => 'import'; +our @EXPORT = qw/yath make_example_dir/; + +my $pdir = tempdir(CLEANUP => 1); + +require App::Yath; +my $apppath = App::Yath->app_path; + +sub cover { + return unless $ENV{T2_DEVEL_COVER}; + $ENV{T2_COVER_SELF} = 1; + return '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; +} + +sub yath { + my %params = @_; + + my $ctx = context(); + + my $cmd = delete $params{cmd} // delete $params{command}; + my $cli = delete $params{cli} // delete $params{args} // []; + my $pre = delete $params{pre} // delete $params{pre_command} // []; + my $env = delete $params{env} // {}; + my $enc = delete $params{encoding}; + my $prefix = delete $params{prefix}; + + my $subtest = delete $params{test} // delete $params{tests} // delete $params{subtest}; + my $exittest = delete $params{exit}; + + my $debug = delete $params{debug} // 0; + my $inc = delete $params{inc} // 1; + my $capture = delete $params{capture} // 1; + my $log = delete $params{log} // 0; + + my $no_app_path = delete $params{no_app_path}; + my $lib = delete $params{lib} // []; + + if (keys %params) { + croak "Unexpected parameters: " . join (', ', sort keys %params); + } + + my (@inc, @dev); + if ($inc) { + my ($pkg, $file) = caller(); + my $dir = $file; + $dir =~ s/\.t2?$//g; + + my $inc = File::Spec->catdir($dir, 'lib'); + push @dev => "-D$inc" if -d $inc; + } + + my ($wh, $cfile); + if ($capture) { + ($wh, $cfile) = tempfile("yath-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.out'); + $wh->autoflush(1); + } + + my (@log, $logfile); + if ($log) { + my $fh; + ($fh, $logfile) = tempfile("yathlog-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.jsonl'); + close($fh); + @log = ('-F' => $logfile); + print "DEBUG: log file = '$logfile'\n" if $debug; + } + + unless ($no_app_path) { + push @inc => "-I$apppath" if $cmd =~ m/^(test|start|projects)$/; + push @dev => "-D$apppath"; + } + + my @cover = cover(); + + my $yath = find_yath; + my @cmd = ($^X, @$lib, @cover, $yath, @$pre, @dev, $cmd ? ($cmd) : (), @inc, @log, @$cli); + + print "DEBUG: Command = " . join(' ' => @cmd) . "\n" if $debug; + + local %ENV = %ENV; + $ENV{YATH_PERSISTENCE_DIR} = $pdir; + $ENV{YATH_CMD} = $cmd; + $ENV{NESTED_YATH} = 1; + $ENV{'YATH_SELF_TEST'} = 1; + $ENV{$_} = $env->{$_} for keys %$env; + my $pid = run_cmd( + no_set_pgrp => 1, + $capture ? (stderr => $wh, stdout => $wh) : (), + command => \@cmd, + run_in_parent => [sub { close($wh) }], + ); + + my (@lines, $exit); + if ($capture) { + open(my $rh, '<', $cfile) or die "Could not open output file: $!"; + apply_encoding($rh, $enc) if $enc; + $rh->blocking(0); + while (1) { + seek($rh, 0, SEEK_CUR); # CLEAR EOF + my @new = <$rh>; + push @lines => @new; + print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; + + waitpid($pid, WNOHANG) or next; + $exit = $?; + last; + } + + while (my @new = <$rh>) { + push @lines => @new; + print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; + } + } + else { + print "DEBUG: Waiting for $pid\n" if $debug; + waitpid($pid, 0); + $exit = $?; + } + + print "DEBUG: Exit: $exit\n" if $debug; + + my $out = { + exit => $exit, + $capture ? (output => join('', @lines)) : (), + $log ? (log => Test2::Harness::Util::File::JSONL->new(name => $logfile)) : (), + }; + + my $name = join(' ', map { length($_) < 30 ? $_ : substr($_, 0, 10) . "[...]" . substr($_, -10) } grep { defined($_) } $prefix, 'yath', @$pre, $cmd ? ($cmd) : (), @$cli); + run_subtest( + $name, + sub { + if (defined $exittest) { + my $ictx = context(level => 3); + is($exit, $exittest, "Exit Value Check"); + $ictx->release; + } + + if ($subtest) { + local $_ = $out->{output}; + local $? = $out->{exit}; + $subtest->($out); + } + + my $ictx = context(level => 3); + + $ictx->diag("Command = " . join(' ' => grep { defined $_ } @cmd) . "\nExit = $exit\n==== Output ====\n$out->{output}\n========") + unless $ictx->hub->is_passing; + + $ictx->release; + }, + {buffered => 1}, + $out, + ) if $subtest || defined $exittest; + + $ctx->release; + + return $out; +} + +sub _gen_passing_test { + my ($dir, $subdir, $file) = @_; + + my $path = File::Spec->catdir($dir, $subdir); + my $full = File::Spec->catfile($path, $file); + + mkdir($path) or die "Could not make $subdir subdir: $!" + unless -d $path; + + open(my $fh, '>', $full); + print $fh "use Test2::Tools::Tiny;\nok(1, 'a passing test');\ndone_testing\n"; + close($fh); + + return $full; +} + +sub make_example_dir { + my $dir = tempdir(CLEANUP => 1, TMP => 1); + + _gen_passing_test($dir, 't', 'test.t'); + _gen_passing_test($dir, 't2', 't2_test.t'); + _gen_passing_test($dir, 'xt', 'xt_test.t'); + + return $dir; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Tester - Tools for testing yath + +=head1 DESCRIPTION + +This package provides utilities for running yath from within tests to verify +its behavior. This is primarily used for integration testing of yath and for +third party components. + +=head1 SYNOPSIS + + use App::Yath::Tester qw/yath/; + + my $result = yath( + # Command and arguments + command => 'test', + args => ['-pMyPlugin', 'path/to/test', ...], + + # Exit code we expect from yath + exit => 0, + + # Subtest to verify results + test => sub { + my $result = shift; + + # Redundant since we have the exit check above + is($result->{exit}, 0, "Verify exit"); + + is($result->{output}, $expected_output, "Got the expected output from yath"); + }, + ); + +=head1 EXPORTS + +There are 2 exports from this module. + +=head2 $result = yath(...) + + my $result = yath( + # Command and arguments + command => 'test', + args => ['-pMyPlugin', 'path/to/test', ...], + + # Exit code we expect from yath + exit => 0, + + # Subtest to verify results + test => sub { + my $result = shift; + + # Redundant since we have the exit check above + is($result->{exit}, 0, "Verify exit"); + + is($result->{output}, $expected_output, "Got the expected output from yath"); + }, + ); + +=head3 ARGUMENTS + +=over 4 + +=item cmd => $command + +=item command => $command + +Either 'cmd' or 'command' can be used. This argument takes a string that should +be a command name. + +=item cli => \@ARGS + +=item args => \@ARGS + +Either 'cli' or 'args' can be used. If none are provided an empty arrayref is +used. This argument takes an arrayref of arguments to the yath command. + + $ yath [PRE_COMMAND] [COMMAND] [ARGS] + +=item pre => \@ARGS + +=item pre_command => \@ARGS + +Either 'pre' or 'pre_command' can be used. An empty arrayref is used if none +are provided. These are arguments provided to yath BEFORE the command on the +command line. + + $ yath [PRE_COMMAND] [COMMAND] [ARGS] + +=item env => \%ENV + +Provide custom environment variable values to set before running the yath +command. + +=item encoding => $encoding_name + +If you expect your yath command's output to be in a specific encoding you can +specify it here to make sure the C<< $result->{output} >> text has been read +properly. + +=item test => sub { ... } + +=item tests => sub { ... } + +=item subtest => sub { ... } + +These 3 arguments are all aliases for the same thing, only one should be used. +The codeblock will be called with C<$result> as the onyl argument. The +codeblock will be run as a subtest. If you specify the C<'exit'> argument that +check will also happen in the same subtest. + + test => sub { + my $result = shift; + + ... verify result ... + }, + +=item exit => $integer + +Verify that the yath command exited with the specified exit code. This check +will be run in a subtest. If you specify a custom subtest then this check will +appear to come from that subtest. + +=item debug => $integer + +Output debug info in realtime, depending on the $integer value this may include +the output from the yath command being run. + + 0 - No debugging + 1 - Output the command and other action being taken by the tool + 2 - Echo yath output as it happens + +=item inc => $bool + +This defaults to true. + +When true the tool will look for a directory next to your test file with an +identical name except that '.t' or '.t2' will be stripped from it. If that +directory exists it will be added as a dev-lib to the yath command. + +If your test file is 't/foo/bar.t' then your yath command will look like this: + + $ yath -D=t/foo/bar [PRE-COMMAND] [COMMAND] [ARGS] + +=item capture => $bool + +Defaults to true. + +When true the yath output will be captured and put into +C<< $result->{output} >>. + +=item log => $bool + +Defaults to false. + +When true yath will be instructed to produce a log, the log will be accessible +via C<< $result->{log} >>. C<< $result->{log} >> will be an instance of +L<Test2::Harness::Util::File::JSONL>. + +=item no_app_path => $bool + +Default to false. + +Normally C<< -D=/path/to/lib >> is added to the yath command where +C<'/path/to/lib'> is the path the the lib dir L<App::Yath> was loaded from. +This normally insures the correct version of yath libraries is loaded. + +When this argument is set to true the path is not added. + +=item lib => [...] + +This poorly named argument allows you to inject command line argumentes between +C<perl> and C<yath> in the command. + + perl [LIB] path/to/yath [PRE-COMMAND] [COMMAND] [ARGS] + +=back + +=head3 RESULT + +The result hashref may containt he following fields depending on the arguments +passed into C<yath()>. + +=over 4 + +=item exit => $integer + +Exit value returned from yath. + +=item output => $string + +The output produced by the yath command. + +=item log => $jsonl_object + +An instance of L<Test2::Harness::Util::File::JSONL> opened from the log file +produced by the yath command. + +B<Note:> By default no logging is done, you must specify the C<< log => 1 >> +argument to enable it. + +=back + +=head2 $path = make_example_dir() + +This will create a temporary directory with 't', 't2', and 'xt' subdirectories +each of which will contain a single passing test. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/App/Yath/Util.pm b/libold2/App/Yath/Util.pm new file mode 100644 index 000000000..9d0a96ca1 --- /dev/null +++ b/libold2/App/Yath/Util.pm @@ -0,0 +1,369 @@ +package App::Yath::Util; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Test2::Harness::Util qw/clean_path/; +use Test2::Harness::Util::File::JSON; + +use Cwd qw/realpath/; +use Importer Importer => 'import'; +use Config qw/%Config/; +use Carp qw/croak/; + +our @EXPORT_OK = qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath +}; + +sub find_yath { + return $App::Yath::Script::SCRIPT if defined $App::Yath::Script::SCRIPT; + + if (-d 'scripts') { + my $script = File::Spec->catfile('scripts', 'yath'); + return $App::Yath::Script::SCRIPT = clean_path($script) if -e $script && -x $script; + } + + my @keys = qw{ + bin binexp initialinstalllocation installbin installscript + installsitebin installsitescript installusrbinperl installvendorbin + scriptdir scriptdirexp sitebin sitebinexp sitescript sitescriptexp + vendorbin vendorbinexp + }; + + my %seen; + for my $path (@Config{@keys}) { + next unless $path; + next if $seen{$path}++; + + my $script = File::Spec->catfile($path, 'yath'); + next unless -f $script && -x $script; + + $App::Yath::Script::SCRIPT = $script = clean_path($script); + return $script; + } + + die "Could not find yath in Config paths"; +} + +sub isolate_stdout { + # Make $fh point at STDOUT, it is our primary output + open(my $fh, '>&', STDOUT) or die "Could not clone STDOUT: $!"; + select $fh; + $| = 1; + + # re-open STDOUT redirected to STDERR + open(STDOUT, '>&', STDERR) or die "Could not redirect STDOUT to STDERR: $!"; + select STDOUT; + $| = 1; + + # Yes, we want to keep STDERR selected + select STDERR; + $| = 1; + + return $fh; +} + +sub is_generated_test_pl { + my ($file) = @_; + + open(my $fh, '<', $file) or die "Could not open '$file': $!"; + + my $count = 0; + while (my $line = <$fh>) { + last if $count++ > 5; + next unless $line =~ m/^# THIS IS A GENERATED YATH RUNNER TEST$/; + return 1; + } + + return 0; +} + + +sub find_in_updir { + my $path = shift; + return clean_path($path) if -f $path; + + my %seen; + while(1) { + $path = File::Spec->catdir('..', $path); + my $check = eval { realpath(File::Spec->rel2abs($path)) }; + last unless $check; + last if $seen{$check}++; + return $check if -f $check; + } + + return; +} + +sub _find_pfile { + my ($settings, %params) = @_; + + croak "Settings is a required argument" unless $settings; + + # First do the entire search without vivify + if ($params{vivify}) { + my $found = find_pfile($settings, %params, vivify => 0); + return $found if $found; + } + + my $yath = $settings->harness; + + if (my $pfile = $yath->persist_file) { + return $pfile if -f $pfile || $params{vivify}; + + return; # Specified, but not found and no vivify + } + + my $basename = "yath-persist.json"; + my $user = $ENV{USER}; + my $hostname = hostname(); + my $project = $yath->project; + + my @names = ($basename); + @names = (@names, map { "$project-$_" } @names) if $project; + @names = (@names, map { "$hostname-$_" } @names) if $hostname; + @names = (@names, map { "$user-$_" } @names) if $user; + @names = reverse map { ".$_" } @names; + + my $set_dir = $yath->persist_dir // $ENV{YATH_PERSISTENCE_DIR}; + my $dir = $set_dir // $ENV{TMPDIR} // $ENV{TEMPDIR} // File::Spec->tmpdir; + + # If a dir was specified, or if the current dir is not writable then we must use $dir/$name + if ($project || $set_dir || !-w '.') { + for my $name (@names) { + my $pfile = clean_path(File::Spec->catfile($dir, $name)); + return $pfile if -f $pfile; + } + + return clean_path(File::Spec->catfile($dir, $names[0])) if $params{vivify}; + return; # Not found + } + + # Fall back to using the current dir (which must be writable) + for my $name (@names) { + my $pfile = find_in_updir($name); + return $pfile if $pfile && -f $pfile; + } + + # Creating it here! + return clean_path(File::Spec->catfile('.', $names[0])) if $params{vivify}; + + # Nope, nothing. + return; +} + +sub fit_to_width { + my ($width, $join, $text) = @_; + + my @parts = ref($text) ? @$text : split /\s+/, $text; + + my @out; + + my $line = ""; + for my $part (@parts) { + my $new = $line ? "$line$join$part" : $part; + + if ($line && length($new) > $width) { + push @out => $line; + $line = $part; + } + else { + $line = $new; + } + } + push @out => $line if $line; + + return join "\n" => @out; +} + +my $SEEN_ERROR = 0; +sub find_pfile { + my ($settings, %params) = @_; + my $pfile = _find_pfile($settings, %params) or return; + + return $pfile unless -e $pfile; + return $pfile if $params{no_checks}; + return $pfile if $SEEN_ERROR; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + + $data->{version} //= ''; + $data->{hostname} //= ''; + $data->{user} //= ''; + $data->{pid} //= ''; + $data->{dir} //= ''; + + my $hostname = hostname(); + my $user = $ENV{USER}; + + my @bad; + + push @bad => "** Version mismatch, persistent runner is version $data->{version}, current is version $VERSION. **" + if $data->{version} ne $VERSION; + + push @bad => "** Hostname mismatch, persistent runner hostname is '$data->{hostname}', current hostname is '$hostname'. **" + if $data->{hostname} ne $hostname; + + push @bad => "** User mismatch, persistent runner user is '$data->{user}', current user is '$user'. **" + if $data->{user} ne $user; + + push @bad => "** Workdir missing, persistent runner is supposed to be at '$data->{dir}', but it does not exist. **" + unless -d $data->{dir}; + + push @bad => "** PID not running, persistent runner is supposed to be running with PID '$data->{pid}', but it is not. **" + unless kill(0, $data->{pid}); + + return $pfile unless @bad; + + my $break = ('=' x 120) . "\n"; + my $msg = join "\n" => $break, @bad, <<" EOT", $break; + +Errors like this usually indicate that the persistent runner has gone away. +Maybe the system was shut down improperly, or maybe the process was killed too +quickly to clean up after itself. + +Here is the information indicated by the persistence file: + Runner PID: $data->{pid} + Runner Vers: $data->{version} + Runner user: $data->{user} + Runner host: $data->{hostname} + Working dir: $data->{dir} + +If the persistent runner is truly gone you should delete the following file to +continue: + +$pfile + EOT + + $SEEN_ERROR = 1; + die $msg unless $params{no_fatal}; + warn $msg unless $params{no_warn}; + return $pfile; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Util - General utilities for yath that do not fit anywhere else. + +=head1 DESCRIPTION + +This package exports several tools used throughout yath that did not fit into +any other package. + +=head1 SYNOPSIS + + use App::Yath::Util qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath + }; + +=head1 EXPORTS + +Note that nothing is exported by default, you must request each function to +import. + +=over 4 + +=item $path_to_pfile = find_pfile($settings, %params) + +The first argument must be an instance of L<Test2::Harness::Settings>. + +Currently the only supported param is C<vivify>, when set to true the pfile +will be created if one does not already exist. + +The pfile is a file that tells yath that a persistent runner is active, and how +to communicate with it. + +=item $path_to_file = find_in_updir($file_name) + +Look for C<$file_name> in the current directory or any parent directory. + +=item $bool = is_generated_test_pl($path_to_test_file) + +Check if the specified test file was generated by the C<yath init> command. + +=item fit_to_width($width, $join, $text) + +This will split the C<$text> on space, and then recombine it using C<$join> +inserting newlines as necessary in an attempt to fit the text into C<$width> +horizontal characters. If any words are larger than C<$width> they will not be +split and text-wrapping may occur if used for terminal display. + +=item $stdout = isolate_stdout() + +This will close STDOUT and reopen it to point at STDERR. The result of this is +that any print statement that does not specify a fielhandle will print to +STDERR instead of STDOUT, in addition any print directly to STDOUT will instead +go to STDERR. A filehandle to the real STDOUT is returned for you to use when +you actually want to write to STDOUT. + +This is used by some yath processes that need to print structured data to +STDOUT without letting any third part modules they may load write to the real +STDOUT. + +=item $path_to_script = find_yath() + +This will attempt to find the C<yath> command line script. When possible this +will return the path that was used to launch yath. If yath was not run to start +the process it will search the paths specified in the L<Config> module. This +will throw an exception if the script cannot be found. + +Note: The result is cached so that subsequent calls will return the same path +even if something installs a new yath script in another location that would +otherwise be found first. This guarentees that a single process will not switch +scripts. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Formatter/QVF.pm b/libold2/Test2/Formatter/QVF.pm new file mode 100644 index 000000000..91a8aae3f --- /dev/null +++ b/libold2/Test2/Formatter/QVF.pm @@ -0,0 +1,139 @@ +package Test2::Formatter::QVF; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +BEGIN { require Test2::Formatter::Test2; our @ISA = qw(Test2::Formatter::Test2) } + +use Test2::Util::HashBase qw{ + -job_buffers + -real_verbose +}; + +sub init { + my $self = shift; + $self->SUPER::init(); + + $self->{+REAL_VERBOSE} = $self->{+VERBOSE}; + + $self->{+VERBOSE} ||= 100; +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + + return if $f && $f->{__RENDER__}->{update_active_disp}++; + + $self->SUPER::update_active_disp($f); +} + +sub write { + my ($self, $e, $num, $f) = @_; + + return $self->SUPER::write($e, $num, $f) if $self->{+REAL_VERBOSE}; + + $f ||= $e->facet_data; + + my $job_id = $f->{harness}->{job_id}; + + push @{$self->{+JOB_BUFFERS}->{$job_id}} => [$e, $num, $f] + if $job_id; + + my $show = $self->update_active_disp($f); + + if ($f->{harness_job_end} || !$job_id) { + $show = 1; + + my $buffer = delete $self->{+JOB_BUFFERS}->{$job_id}; + + if($f->{harness_job_end}->{fail}) { + $self->SUPER::write(@{$_}) for @$buffer; + } + else { + $f->{info} = [grep { $_->{tag} ne 'TIME' } @{$f->{info}}] if $f->{info}; + $self->SUPER::write($e, $num, $f) + } + } + + $self->{+ECOUNT}++; + + return unless $self->{+TTY}; + return unless $self->{+PROGRESS}; + + $show ||= 1 unless $self->{+ECOUNT} % 10; + + if ($show) { + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->{+IO}; + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::QVF - Test2 formatter that is [Q]uiet but [V]erbose on +[F]ailure. + +=head1 DESCRIPTION + +This formatter is a subclass of L<Test2::Formatter::Test2>. This one will +buffer all output from a test file and only show it to you if there is a +failure. Most of the time it willonly show you the completion notifications for +each test. + +=head1 SYNOPSIS + + $ yath test --qvf ... + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/libold2/Test2/Formatter/Stream.pm b/libold2/Test2/Formatter/Stream.pm new file mode 100644 index 000000000..d14999177 --- /dev/null +++ b/libold2/Test2/Formatter/Stream.pm @@ -0,0 +1,518 @@ +package Test2::Formatter::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Time::HiRes qw/time/; +use IO::Handle; +use File::Spec(); +use List::Util qw/first/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/JSON JSON_IS_XS/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; + +use Test2::Util qw/get_tid ipc_separator/; + +use parent qw/Test2::Formatter/; +use Test2::Util::HashBase qw/-io _encoding _no_header _no_numbers _no_diag -stream_id -tb -tb_handles -dir -_pid -_tid -_fh <job_id -ugids/; + +BEGIN { + no warnings 'once'; + + if (my $use_pipe = $ENV{T2_HARNESS_USE_ATOMIC_PIPE}) { + require Atomic::Pipe; + *USE_PIPE = sub() { 1 }; + $Test2::Harness::STDOUT_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDOUT); + $Test2::Harness::STDOUT_APIPE->set_mixed_data_mode(); + + if ($use_pipe > 1) { + *USE_PIPE_STDERR = sub() { 1 }; + $Test2::Harness::STDERR_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDERR); + $Test2::Harness::STDERR_APIPE->set_mixed_data_mode(); + } + else { + *USE_PIPE_STDERR = sub() { 0 }; + } + } + else { + *USE_PIPE = sub() { 0 }; + *USE_PIPE_STDERR = sub() { 0 }; + $Test2::Harness::STDOUT_APIPE = undef; + $Test2::Harness::STDERR_APIPE = undef; + } +} + + + +BEGIN { + my $J = JSON->new; + $J->indent(0); + $J->convert_blessed(1); + $J->allow_blessed(1); + $J->utf8(1); + $J->ascii(1); + + require constant; + constant->import(ENCODER => $J); + + if (JSON_IS_XS) { + require JSON::PP; + my $JPP = JSON::PP->new; + $JPP->indent(0); + $JPP->convert_blessed(1); + $JPP->allow_blessed(1); + $JPP->utf8(1); + $JPP->ascii(1); + + constant->import(ENCODER_PP => $JPP); + } +} + +my ($ROOT_TID, $ROOT_PID, $ROOT_DIR, $ROOT_JOB_ID, $ROOT_UGIDS); +sub import { + my $class = shift; + my %params = @_; + + confess "$class no longer accept the 'file' argument, it now takes a 'dir' argument" + if exists $params{file}; + + $class->SUPER::import(); + + $ROOT_PID = $$; + $ROOT_TID = get_tid(); + $ROOT_DIR = $params{dir} if $params{dir}; + $ROOT_JOB_ID = $params{job_id} if $params{job_id}; + $ROOT_UGIDS = [$<, $>, $(, $)]; + + if ($ROOT_DIR && ! -d $ROOT_DIR) { + mkdir($ROOT_DIR) or die "Could not make root dir: $!"; + } +} + +sub hide_buffered { 0 } + +sub fh { + my $self = shift; + + my $dir = $self->{+DIR} or return undef; + + my $pid = $self->{+_PID}; + my $tid = $self->{+_TID}; + + if ($pid && $pid != $$) { + delete $self->{+_PID}; + delete $self->{+_FH}; + } + + if ($tid && $tid != get_tid()) { + delete $self->{+_TID}; + delete $self->{+_FH}; + } + + return $self->{+_FH} if $self->{+_FH}; + + $self->{+STREAM_ID} = 1; + + $pid = $self->{+_PID} = $$; + $tid = $self->{+_TID} = get_tid(); + + my $file = File::Spec->catfile($dir, join(ipc_separator() => 'events', $pid, $tid) . ".jsonl"); + + my @now = ($<, $>, $(, $)); + local ($<, $>, $(, $)) = @{$self->{+UGIDS}} if $self->{+UGIDS} && first { $self->{+UGIDS}->[$_] ne $now[$_] } 0 .. $#now; + + mkdir($dir) or die "Could not make dir '$dir': $!" unless -d $dir; + confess "File '$file' already exists!" if -f $file; + open(my $fh, '>', $file) or die "Could not open file: $file"; + $fh->autoflush(1); + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + return $self->{+_FH} = $fh; +} + +sub init { + my $self = shift; + + $self->{+STREAM_ID} = 1; + $self->{+UGIDS} //= [$<, $>, $(, $)]; + + # To create necessary directories as soon as possible + $self->fh(); + + for (@{$self->{+IO}}) { + $_->autoflush(1); + } + + STDOUT->autoflush(1); + STDERR->autoflush(1); + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stdout()->autoflush(1); + Test2::API::test2_stderr()->autoflush(1); + } + + if ($self->{check_tb}) { + require Test::Builder::Formatter; + $self->{+TB} = Test::Builder::Formatter->new(); + $self->{+TB_HANDLES} = [@{$self->{+TB}->handles}]; + } +} + +sub new_root { + my $class = shift; + my %params = @_; + + $ROOT_PID = $$ unless defined $ROOT_PID; + $ROOT_TID = get_tid() unless defined $ROOT_TID; + + confess "new_root called from child process!" + if $ROOT_PID != $$; + + confess "new_root called from child thread!" + if $ROOT_TID != get_tid(); + + require Test2::API; + my $io = $params{+IO} = [Test2::API::test2_stdout(), Test2::API::test2_stderr()]; + $_->autoflush(1) for @$io; + + confess "T2_STREAM_FILE is no longer used, see T2_STREAM_DIR" + if exists $ENV{T2_STREAM_FILE}; + + $params{+DIR} ||= $ENV{T2_STREAM_DIR} || $ROOT_DIR; + $params{+JOB_ID} ||= $ENV{T2_STREAM_JOB_ID} || $ROOT_JOB_ID || 1; + + # DO NOT REOPEN THEM! + delete $ENV{T2_FORMATTER} if $ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} eq 'Stream'; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_JOB_ID}; + $ROOT_DIR = undef; + + $params{check_tb} = 1 if $INC{'Test/Builder.pm'}; + + $params{+UGIDS} = $ROOT_UGIDS if $ROOT_UGIDS; + + return $class->new(%params); +} + +sub record { + my $self = shift; + my ($facets, $num) = @_; + + my $stamp = time; + my $times = [times]; + + my @sync = @{$self->{+IO}}; + my $leader = 0; + + my $fh = $self->fh; + unless($fh) { + $leader = 1; + $fh = shift @sync; + } + + if ($facets->{control}->{halt}) { + my $reason = $facets->{control}->{details} || ""; + + if ($leader) { + print $fh "\nBail out! $reason\n"; + } + else { + open(my $bh, '>', File::Spec->catfile($self->{+DIR}, 'bail')) or die "Could not create bail file: $!"; + print $bh $reason; + close($bh); + } + } + + my $tid = get_tid(); + my $id = $self->{+STREAM_ID}++; + my $event_id = $facets->{about}->{uuid} ||= gen_uuid(); + + my $json; + { + no warnings 'once'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + + if (JSON_IS_XS) { + for my $encoder (ENCODER, ENCODER_PP) { + local $@; + my $ok = eval { + $json = $encoder->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + 1; + }; + my $err = $@; + last if $ok; + + # Intercept bug in JSON::XS so we can fall back to JSON::PP + next if $encoder eq ENCODER && $err =~ m/Modification of a read-only value attempted/; + + # Different error, time to die. + die $err; + } + } + else { + $json = ENCODER->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + } + } + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $job_id = $self->{+JOB_ID}; + + if (USE_PIPE) { + $Test2::Harness::STDOUT_APIPE->write_message($json); + $Test2::Harness::STDERR_APIPE->write_message(qq/{"event_id":"$event_id"}/) if USE_PIPE_STDERR; + } + else { + print $fh $leader ? ("T2-HARNESS-$job_id-EVENT: ", $json, "\n") : ($json, "\n"); + print $_ "T2-HARNESS-$job_id-ESYNC: ", join(ipc_separator() => $$, $tid, $id) . "\n" for @sync; + } +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + $self->record({control => {encoding => $enc}}); + $self->_set_encoding($enc); + $self->{+TB}->encoding($enc) if $self->{+TB}; + } + + return $self->{+_ENCODING}; +} + +sub _set_encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + apply_encoding(\*STDOUT, $enc); + apply_encoding(\*STDERR, $enc); + + if (!USE_PIPE) { + my $job_id = $self->{+JOB_ID}; + for my $fh (@{$self->{+IO}}) { + print $fh "T2-HARNESS-$job_id-ENCODING: $enc\n"; + apply_encoding($fh, $enc); + } + } + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub { }; +} + +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + $self->_set_encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + # Hide these if we must, but do not remove them for good. + local $f->{info} if $self->{+_NO_DIAG}; + local $f->{plan} if $self->{+_NO_HEADER}; + + my $tb_only = 0; + if ($self->{+TB}) { + $tb_only ||= $self->{+TB_HANDLES}->[0] != $self->{+TB}->{handles}->[0]; + $tb_only ||= $self->{+TB_HANDLES}->[1] != $self->{+TB}->{handles}->[1]; + + my $todo_match = $self->{+TB_HANDLES}->[0] == $self->{+TB}->{handles}->[2] + || $self->{+TB_HANDLES}->[1] == $self->{+TB}->{handles}->[2]; + + $tb_only ||= !$todo_match; + + if ($tb_only) { + my $buffered = hub_truth($f)->{buffered}; + $self->{+TB}->write($e, $num, $f) if $self->{+TB} && !$buffered; + return; + } + } + + $self->record($f, $num); +} + +sub no_header { $_[0]->{+_NO_HEADER} } +sub no_diag { $_[0]->{+_NO_DIAG} } +sub no_numbers { $_[0]->{+_NO_NUMBERS} } + +sub handles { + my $self = shift; + + return $self->{+TB}->handles if $self->{+TB}; + return; +} + +sub set_no_header { + my $self = shift; + ($self->{+_NO_HEADER}) = @_; + $self->{+TB}->set_no_header(@_) if $self->{+TB}; + $self->{+_NO_HEADER}; +} + +sub set_no_diag { + my $self = shift; + ($self->{+_NO_DIAG}) = @_; + $self->{+TB}->set_no_diag(@_) if $self->{+TB}; + $self->{+_NO_DIAG}; +} + +sub set_no_numbers { + my $self = shift; + ($self->{+_NO_NUMBERS}) = @_; + $self->{+TB}->set_no_numbers(@_) if $self->{+TB}; + $self->{+_NO_NUMBERS}; +} + +sub set_handles { + my $self = shift; + return $self->{+TB}->set_handles(@_) if $self->{+TB}; + return; +} + +sub terminate { + my $self = shift; + return $self->SUPER::terminate(@_) unless $self->{+TB}; + return $self->{+TB}->terminate(@_); +} + +sub finalize { + my $self = shift; + return $self->SUPER::finalize(@_) unless $self->{+TB}; + return $self->{+TB}->finalize(@_); +} + +sub DESTROY {} + +our $AUTOLOAD; + +sub AUTOLOAD { + my $this = shift; + + my $meth = $AUTOLOAD; + $meth =~ s/^.*:://g; + + my $type = ref($this); + + return $this->{+TB}->$meth(@_) + if $type && $this->{+TB} && $this->{+TB}->can($meth); + + $type ||= $this; + croak qq{Can't locate object method "$meth" via package "$type"}; +} + +sub isa { + my $in = shift; + return $in->SUPER::isa(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::isa(@_) || $in->{+TB}->isa(@_); +} + +sub can { + my $in = shift; + return $in->SUPER::can(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::can(@_) || $in->{+TB}->can(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Stream - Test2 Formatter that directly writes events. + +=head1 DESCRIPTION + +This formatter writes all test2 events to event files (one per process/thread) +instead of writing them to STDERR/STDOUT. It will output synchronization +messages to STDERR/STDOUT every time an event is written. From this data the +test output can be properly reconstructed in order with STDERR/STDOUT and +events mostly synced so that they appear in the correct order. + +This formatter is not usually useful to humans. This formatter is used by +L<Test2::Harness> when possible to prevent the loss of data that normally +occurs when TAP is used. + +=head1 SYNOPSIS + +If you really want your test to output this: + + use Test2::Formatter::Stream; + use Test2::V0; + ... + +Otherwise just use L<App::Yath> without the C<--no-stream> argument and this +formatter will be used when possible. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Formatter/Test2.pm b/libold2/Test2/Formatter/Test2.pm new file mode 100644 index 000000000..c4f599639 --- /dev/null +++ b/libold2/Test2/Formatter/Test2.pm @@ -0,0 +1,811 @@ +package Test2::Formatter::Test2; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Term qw/term_size/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; +use Test2::Util qw/IS_WIN32 clone_io/; +use Time::HiRes qw/time/; +use IO::Handle; + +use File::Spec(); +use Test2::Formatter::Test2::Composer; + +use parent 'Test2::Formatter'; + +sub import { + my $class = shift; + return if $ENV{HARNESS_ACTIVE}; + $class->SUPER::import; +} + +use Test2::Util::HashBase qw{ + -composer + -last_depth + -_buffered + <job_io + +io + <enc_io + -_encoding + -show_buffer + -color + -progress + -tty + -no_wrap + -verbose + -job_length + -ecount + -job_colors + -active_files + -_active_disp + -_file_stats + -job_names + -is_persistent + -interactive + +noname_counter +}; + +sub TAG_WIDTH() { 8 } + +sub hide_buffered() { 0 } + +sub DEFAULT_TAG_COLOR() { + return ( + 'DEBUG' => Term::ANSIColor::color('red'), + 'DIAG' => Term::ANSIColor::color('yellow'), + 'ERROR' => Term::ANSIColor::color('red'), + 'FATAL' => Term::ANSIColor::color('bold red'), + 'FAIL' => Term::ANSIColor::color('red'), + 'HALT' => Term::ANSIColor::color('bold red'), + 'PASS' => Term::ANSIColor::color('green'), + '! PASS !' => Term::ANSIColor::color('cyan'), + 'TODO' => Term::ANSIColor::color('cyan'), + 'NO PLAN' => Term::ANSIColor::color('yellow'), + 'SKIP' => Term::ANSIColor::color('bold cyan'), + 'SKIP ALL' => Term::ANSIColor::color('bold white on_blue'), + 'STDERR' => Term::ANSIColor::color('yellow'), + 'RUN INFO' => Term::ANSIColor::color('bold bright_blue'), + 'JOB INFO' => Term::ANSIColor::color('bold bright_blue'), + 'LAUNCH' => Term::ANSIColor::color('bold bright_white'), + 'RETRY' => Term::ANSIColor::color('bold bright_white'), + 'PASSED' => Term::ANSIColor::color('bold bright_green'), + 'TO RETRY' => Term::ANSIColor::color('bold bright_yellow'), + 'FAILED' => Term::ANSIColor::color('bold bright_red'), + 'REASON' => Term::ANSIColor::color('magenta'), + 'TIMEOUT' => Term::ANSIColor::color('magenta'), + 'TIME' => Term::ANSIColor::color('blue'), + 'MEMORY' => Term::ANSIColor::color('blue'), + ); +} + +sub DEFAULT_FACET_COLOR() { + return ( + time => Term::ANSIColor::color('blue'), + memory => Term::ANSIColor::color('blue'), + about => Term::ANSIColor::color('magenta'), + amnesty => Term::ANSIColor::color('cyan'), + assert => Term::ANSIColor::color('bold bright_white'), + control => Term::ANSIColor::color('bold red'), + error => Term::ANSIColor::color('yellow'), + info => Term::ANSIColor::color('yellow'), + meta => Term::ANSIColor::color('magenta'), + parent => Term::ANSIColor::color('magenta'), + trace => Term::ANSIColor::color('bold red'), + ); +} + +# These colors all look decent enough to use, ordered to avoid putting similar ones together +use constant DEFAULT_JOB_COLOR_NAMES => ( + 'bold green on_blue', + 'bold blue on_white', + 'bold black on_cyan', + 'bold green on_bright_black', + 'bold dark blue on_white', + 'bold black on_green', + 'bold cyan on_blue', + 'bold black on_white', + 'bold white on_cyan', + 'bold cyan on_bright_black', + 'bold white on_green', + 'bold bright_black on_white', + 'bold white on_blue', + 'bold bright_cyan on_green', + 'bold blue on_cyan', + 'bold white on_bright_black', + 'bold bright_black on_green', + 'bold bright_green on_blue', + 'bold bright_blue on_white', + 'bold bright_white on_bright_black', + 'bold yellow on_blue', + 'bold bright_black on_cyan', + 'bold bright_green on_bright_black', + 'bold blue on_green', + 'bold bright_cyan on_blue', + 'bold bright_blue on_cyan', + 'bold dark bright_white on_bright_black', + 'bold bright_blue on_green', + 'bold dark bright_blue on_white', + 'bold bright_white on_blue', + 'bold bright_cyan on_bright_black', + 'bold bright_white on_cyan', + 'bold bright_white on_green', + 'bold bright_yellow on_blue', + #'bold magenta on_white', + #'bold dark magenta on_white', + #'bold dark cyan on_white', + 'bold dark bright_cyan on_bright_black', + #'bold dark bright_green on_black', + #'bold dark bright_yellow on_black', +); + +sub DEFAULT_JOB_COLOR() { + return map { Term::ANSIColor::color($_) } DEFAULT_JOB_COLOR_NAMES; +} + +sub DEFAULT_COLOR() { + return ( + reset => Term::ANSIColor::color('reset'), + blob => Term::ANSIColor::color('bold bright_black on_white'), + tree => Term::ANSIColor::color('bold bright_white'), + tag_border => Term::ANSIColor::color('bold bright_white'), + ); +} + +my %FACET_TAG_BORDERS = ( + 'default' => ['[', ']'], + 'amnesty' => ['{', '}'], + 'info' => ['(', ')'], + 'error' => ['<', '>'], + 'parent' => [' ', ' '], +); + +sub init { + my $self = shift; + + $self->{+NONAME_COUNTER} //= 1; + + $self->{+COMPOSER} ||= Test2::Formatter::Test2::Composer->new; + + $self->{+VERBOSE} = 1 unless defined $self->{+VERBOSE}; + + $self->{+JOB_LENGTH} ||= 2; + + my $io = $self->{+IO} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + + $self->{+TTY} = -t $io unless defined $self->{+TTY}; + + my $use_color = ref($self->{+COLOR}) ? 1 : delete($self->{+COLOR}); + $use_color = $self->{+TTY} unless defined $use_color; + + if ($use_color && USE_ANSI_COLOR) { + $self->{+SHOW_BUFFER} = 1 unless defined $self->{+SHOW_BUFFER}; + + if ($use_color) { + $self->{+COLOR} = { + DEFAULT_COLOR(), + TAGS => {DEFAULT_TAG_COLOR()}, + FACETS => {DEFAULT_FACET_COLOR()}, + JOBS => [DEFAULT_JOB_COLOR()], + } unless defined $self->{+COLOR}; + + $self->{+JOB_COLORS} = {free => [@{$self->{+COLOR}->{JOBS}}]}; + } + } + else { + $self->{+SHOW_BUFFER} = 0 unless defined $self->{+SHOW_BUFFER}; + } + + $self->{+ECOUNT} //= 0; + + my $reset = $use_color ? Term::ANSIColor::color('reset') : ''; + my $cyan = $use_color ? Term::ANSIColor::color('cyan') : ''; + $self->{+_ACTIVE_DISP} = ["[${cyan}INITIALIZING${reset}]", '']; + $self->{+_FILE_STATS} = { + passed => 0, + failed => 0, + running => 0, + todo => 0, + total => 0, + }; + + +} + +sub io { + my $self = shift; + my ($job_id) = @_; + return $self->{+IO} unless defined $job_id; + return $self->{+JOB_IO}->{$job_id} // $self->{+IO}; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc, $job_id) = @_; + if (defined $job_id) { + my $io; + + unless ($io = $self->{+ENC_IO}->{$enc}) { + $io = $self->{+ENC_IO}->{$enc} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + apply_encoding($io, $enc); + } + + $self->{+JOB_IO}->{$job_id} = $io; + } + else { + apply_encoding($self->{+IO}, $enc); + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + + $f ||= $e->facet_data; + + use Data::Dumper; + print "XXX " . Dumper($e, $f); + + my $should_show = $self->update_active_disp($f); + + $self->{+ECOUNT}++; + + my $job_id = $f->{harness}->{job_id}; + $self->encoding($f->{control}->{encoding}, $job_id) if $f->{control}->{encoding}; + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + return if $depth && (!$self->{+SHOW_BUFFER} || !$self->{+PROGRESS}); + + my $lines; + if (!$self->{+VERBOSE}) { + if ($depth) { + $lines = []; + } + else { + $lines = $self->render_quiet($f); + } + } + elsif ($depth) { + my $tree = $self->render_tree($f, '>'); + $lines = $self->render_buffered_event($f, $tree); + } + else { + my $tree = $self->render_tree($f,); + $lines = $self->render_event($f, $tree); + } + + $should_show ||= $lines && @$lines; + unless ($should_show || $self->{+VERBOSE}) { + if (my $last = $self->{last_rendered}) { + return if time - $last < 0.2; + $self->{last_rendered} = time; + } + else { + $self->{last_rendered} = time; + } + } + + push @{$self->{+JOB_COLORS}->{free}} => delete $self->{+JOB_COLORS}->{used}->{$job_id} + if $job_id && $f->{harness_job_end}; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->io($job_id); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if (!$self->{+VERBOSE}) { + print $io $_, "\n" for @$lines; + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + } + elsif ($depth && $lines && @$lines && !$self->{+INTERACTIVE}) { + print $io $lines->[0]; + $self->{+_BUFFERED} = 1; + } + else { + print $io $_, "\n" for @$lines; + } + + delete $self->{+JOB_IO}->{$job_id} if $job_id && $f->{harness_job_end}; +} + +sub finalize { + my $self = shift; + + my $io = $self->{+IO}; + print $io "\r\e[K" if $self->{+_BUFFERED}; + + return; +} + +sub step { + my $self = shift; + + return unless $self->update_active_disp; + + my $io = $self->io(0); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status(); + $self->{+_BUFFERED} = 1; + } +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + my $should_show = 0; + + my $stats = $self->{+_FILE_STATS}; + + my $out = 0; + $out = $self->update_spinner($stats) unless $stats->{started}; + + return $out unless $f; + + if (my $task = $f->{harness_job_queued}) { + $self->{+JOB_NAMES}->{$task->{job_id}} = $task->{job_name} || $task->{job_id}; + $stats->{total}++; + $stats->{todo}++; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($job->{file})} = $job->{job_name} || $job->{job_id}; + $should_show = 1; + $stats->{running}++; + $stats->{todo}--; + $stats->{started} //= 1; + } + + if ($f->{harness_job_end}) { + my $file = $f->{harness_job_end}->{file}; + delete $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($file)}; + $should_show = 1; + $stats->{running}--; + + if ($f->{harness_job_end}->{fail}) { + $stats->{failed}++; + } + else { + $stats->{passed}++; + } + } + + return $out unless $should_show; + + my $statline = join '|' => ( + $self->_highlight($stats->{passed}, 'P', 'green'), + $self->_highlight($stats->{failed}, 'F', 'red'), + $self->_highlight($stats->{running}, 'R', 'cyan'), + $self->_highlight($stats->{todo}, 'T', 'yellow'), + ); + + $statline = "[$statline]"; + + my $active = $self->{+ACTIVE_FILES}; + + return $self->{+_ACTIVE_DISP} = [$statline, ''] unless $active && keys %$active; + + my $reset = $self->reset; + + my $str .= "("; + { + no warnings 'numeric'; + $str .= join(' ' => map { m{([^/]+)$}; "$active->{$_}:$1" } sort { ($active->{$a} || 0) <=> ($active->{$b} || 0) or $a cmp $b } keys %$active); + } + $str .= ")"; + + $self->{+_ACTIVE_DISP} = [$statline, $str]; + + return 1; +} + +sub update_spinner { + my $self = shift; + my ($stats) = @_; + + $stats->{spinner} //= '|'; + $stats->{spinner_time} //= time - 1; + $stats->{blink_time} //= time - 1; + $stats->{blink} //= ''; + + if (time - $stats->{spinner_time} > 0.1) { + $stats->{spinner_time} = time; + my $start = substr($stats->{spinner}, 0, 1); + $stats->{spinner} = '\\' if $start eq '-'; + $stats->{spinner} = '-' if $start eq '/'; + $stats->{spinner} = '/' if $start eq '|'; + $stats->{spinner} = '|' if $start eq '\\'; + } + elsif(time - $stats->{blink_time} > 0.5) { + $stats->{blink_time} = time; + $stats->{blink} = $stats->{blink} ? '' : 'bold bright_'; + } + else { + return 0; + } + + my $yellow = $self->{+COLOR} ? Term::ANSIColor::color($stats->{blink} . 'yellow') : ''; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + my $green = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_green') : ''; + my $bold = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_white') : ''; + my $reset = $self->reset; + + $self->{+_ACTIVE_DISP} = [ + join( + '' => ( + $bold => "[ ", $reset, + $green => $stats->{spinner}, $reset, + '' => " ", + $self->{+IS_PERSISTENT} + ? ( + $yellow => "Waiting for busy runner", $reset, + '' => " ", + $reset => "(see ", $reset, + $cyan => "yath status", $reset, + $reset => ")", $reset, + ) + : ($yellow => "INITIALIZING", $reset), + '' => " ", + $green => $stats->{spinner}, $reset, + $bold => " ]", $reset, + ) + ), + '', + ]; + + return 1; +} + +sub _highlight { + my $self = shift; + my ($val, $label, $color) = @_; + + return "${label}:${val}" unless $val && $self->{+COLOR}; + return sprintf('%s%s:%d%s', Term::ANSIColor::color($color), $label, $val, $self->reset); +} + + +sub colorstrip { + my $self = shift; + my ($str) = @_; + + return $str unless USE_ANSI_COLOR; + return Term::ANSIColor::colorstrip($str); +} + +sub render_status { + my $self = shift; + + my $reset = $self->reset; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + + my $str = "$self->{+_ACTIVE_DISP}->[0] Events: $self->{+ECOUNT} ${cyan}$self->{+_ACTIVE_DISP}->[1]${reset}"; + + my $max = term_size() || 80; + + if (length($str) > $max) { + my $nocolor = $self->colorstrip($str); + $str = substr($nocolor, 0, $max - 8) . " ...)$reset" if length($nocolor) > $max; + $str =~ s/\(/$cyan(/; + $str =~ s/^\[[^\]]+\]/$self->{+_ACTIVE_DISP}->[0]/; + } + + return $str; +} + +sub render_buffered_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comp = $self->{+COMPOSER}->render_one_line($f) or return; + + return unless @$comp; + return [$self->build_line($tree, @$comp)]; +} + +sub render_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comps = $self->{+COMPOSER}->render_verbose($f); + + my (@parent, @times); + + if ($f->{parent}) { + @parent = $self->render_parent($f, $tree); + + if (@$comps && $comps->[-1]->[0] eq 'times') { + my $times = pop(@$comps); + @times = $self->build_line($tree, @$times); + } + } + + my @out; + + for my $comp (@$comps) { + my $ctree = $tree; + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + push @out => (@parent, @times); + + return \@out; +} + +sub render_quiet { + my $self = shift; + my ($f, $tree) = @_; + + my @out; + + my $comps = $self->{+COMPOSER}->render_brief($f); + for my $comp (@$comps) { + my $ctree = $tree ||= $self->render_tree($f); + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + if ($f->{parent} && !$f->{amnesty}) { + push @out => $self->render_parent($f, $tree ||= $self->render_tree($f), quiet => 1); + } + + return \@out; +} + +sub reset { + my $self = shift; + return $self->{+COLOR} ? $self->{+COLOR}->{reset} : ''; +} + +sub job_color { + my $self = shift; + my ($id, $set) = @_; + return '' unless $self->{+JOB_COLORS}; + return $self->{+JOB_COLORS}->{used}->{$id} || '' unless $set; + return $self->{+JOB_COLORS}->{used}->{$id} ||= shift @{$self->{+JOB_COLORS}->{free}} || ''; +} + +sub render_tree { + my $self = shift; + my ($f, $char) = @_; + $char ||= '|'; + + my $job = ''; + if ($f->{harness} && $f->{harness}->{job_id}) { + my $id = $f->{harness}->{job_id}; + my $name = $self->{+JOB_NAMES}->{$id} //= "^" . $self->{+NONAME_COUNTER}; + + my ($color, $reset) = ('', ''); + if ($self->{+JOB_COLORS}) { + $color = $self->job_color($id, 'set'); + $reset = $self->reset; + } + + my $len = length($name) // 0; + if (!$self->{+JOB_LENGTH} || $len > $self->{+JOB_LENGTH}) { + $self->{+JOB_LENGTH} = $len; + } + else { + $len = $self->{+JOB_LENGTH}; + } + + $job = sprintf("%sjob %${len}s%s ", $color, $name, $reset || ''); + } + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + my @pipes = (' ', map $char, 1 .. $depth); + return join(' ' => $job, @pipes) . ' '; +} + +sub build_line { + my $self = shift; + my ($tree, $facet, $tag, $text) = @_; + + $tree ||= ''; + $tag ||= ''; + $text ||= ''; + chomp($text); + + substr($tree, -2, 1, '+') if $facet eq 'assert'; + + $tag = substr($tag, 0 - TAG_WIDTH, TAG_WIDTH) if length($tag) > TAG_WIDTH; + + my $max = $self->{+TTY} && !$self->{+NO_WRAP} ? (term_size() || 80) : undef; + my $color = $self->{+COLOR}; + my $reset = $self->reset; + my $tcolor = $color ? $color->{TAGS}->{$tag} || $color->{FACETS}->{$facet} || '' : ''; + + my ($ps, $pe) = @{$FACET_TAG_BORDERS{$facet} || $FACET_TAG_BORDERS{default}}; + + $tag = uc($tag); + my $length = length($tag); + if ($length > TAG_WIDTH) { + $tag = substr($tag, 0, TAG_WIDTH); + } + elsif($length < TAG_WIDTH) { + my $pad = (TAG_WIDTH - $length) / 2; + my $padl = $pad + (TAG_WIDTH - $length) % 2; + $tag = (' ' x $padl) . $tag . (' ' x $pad); + } + + my $start; + if ($color) { + my $border = $color->{tag_border} || ''; + $start = "${reset}${border}${ps}${reset}${tcolor}${tag}${reset}${border}${pe}${reset}"; + } + else { + $start = "${ps}${tag}${pe}"; + } + $start .= " "; + + if ($tree) { + if ($color) { + my $trcolor = $color->{tree} || ''; + $start .= $trcolor . $tree . $reset; + } + else { + $start .= $tree; + } + } + + my @lines = split /[\r\n]/, $text; + @lines = ($text) unless @lines; + + my @out; + for my $line (@lines) { + if(@lines > 1 && $max && length("$ps$tag$pe $tree$line") > $max) { + @out = (); + last; + } + + if ($color) { + push @out => "${start}${tcolor}${line}$reset"; + } + else { + push @out => "${start}${line}"; + } + } + + return @out if @out; + + return ( + "$start----- START -----", + $text, + "$start------ END ------", + ) unless $color; + + my $blob = $color->{blob} || ''; + return ( + "$start${blob}----- START -----$reset", + "${tcolor}${text}${reset}", + "$start${blob}------ END ------$reset", + ); +} + +sub render_parent { + my $self = shift; + my ($f, $tree, %params) = @_; + + my $meth = $params{quiet} ? 'render_quiet' : 'render_event'; + + my @out; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness} ||= $f->{harness}; + my $tree = $self->render_tree($sf); + push @out => @{$self->$meth($sf, $tree)}; + } + + return unless @out; + + push @out => ( + $self->build_line("$tree^", 'parent', '', ''), + ); + + return @out; +} + + +sub DESTROY { + my $self = shift; + + my $io = $self->{+IO} or return; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + print $io Term::ANSIColor::color('reset') + if USE_ANSI_COLOR; + + print $io "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2 - An alternative to TAP, used by Test2::Harness. + +=head1 DESCRIPTION + +This formatter is the primary formatter used for final result rendering when +you use Test2::Harness. This formatter is NOT designed to have its output +consumed by code/machine/harnesses. The goal of this formatter is to have +output that is easily read by humans. + +=head1 SYNOPSIS + +If you are running a test directly with perl and want to use this formatter: + + $ perl -MTest2::Formatter::Test2 path/to/test.t + +You could also use the module directly in your test, but that is not +recommended as your test would then be unable to be run via prove or other +harnesses. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Formatter/Test2/Composer.pm b/libold2/Test2/Formatter/Test2/Composer.pm new file mode 100644 index 000000000..d6b642d19 --- /dev/null +++ b/libold2/Test2/Formatter/Test2/Composer.pm @@ -0,0 +1,507 @@ +package Test2::Formatter::Test2::Composer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use List::Util qw/first/; + +sub new { + my $class = shift; + return bless({}, $class); +} + +sub render_one_line { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + return [$f->{render}->[0]->{facet}, uc($f->{render}->[0]->{tag}), $f->{render}->[0]->{details}] + if $f->{render} && @{$f->{render}}; + + return (($class->halt($f))[0]) if $class->{control} && defined $class->{control}->{halt}; + + for my $type (qw/assert errors plan info times about/) { + next unless $f->{$type}; + my $m = "render_$type"; + my ($out) = $class->$m($f); + return $out if defined $out; + } + + return; +} + +sub render_verbose { + my $class = shift; + my ($in, %params) = @_; + + my $f = blessed($in) ? $in->facet_data : $in; + + return [map {[$_->{facet}, uc($_->{tag}), $_->{details}]} @{$f->{render}}] + if $f->{render} && @{$f->{render}}; + + my @out; + + push @out => $class->render_control($f, %params) if $f->{control}; + push @out => $class->render_plan($f) if $f->{plan}; + + if ($f->{assert}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{pass} || $f->{assert}->{no_debug}; + push @out => $class->render_amnesty($f) if $f->{amnesty} && @{$f->{amnesty}}; + } + + push @out => $class->render_info($f) if $f->{info}; + push @out => $class->render_errors($f) if $f->{errors}; + + push @out => $class->render_about($f) + if $f->{about} && !(@out || first { $f->{$_} } qw/stop plan info nest assert/); + + return \@out; +} + +sub render_super_verbose { + my $class = shift; + my ($in) = @_; + + my $out = $class->render_verbose($in, super_verbose => 1); + + my $f = blessed($in) ? $in->facet_data : $in; + + push @$out => $class->render_launch($f) if $f->{harness_job_launch}; + push @$out => $class->render_start($f) if $f->{harness_job_start}; + push @$out => $class->render_exit($f) if $f->{harness_job_exit}; + push @$out => $class->render_end($f) if $f->{harness_job_end}; + + unless (@$out) { + my ($name, $fallback); + for my $k (sort keys %$f) { + my $v = $f->{$k}; + + # Fallback should be longest harness* facet name + $fallback = $k if $k =~ m/harness/ && (!$fallback || length($fallback) < length($k)); + + my $list = ref($v) eq 'ARRAY' ? $v : [$v]; + for my $i (@$list) { + next unless ref($i); + last if $name = $i->{details}; + } + } + + $name //= $fallback // join ', ' => sort keys %$f; + + push @$out => ['harness', 'HARNESS', $name]; + } + + return $out; +} + +sub render_launch { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', 'Job Launched at ' . $f->{harness_job_launch}->{stamp}]; +} + +sub render_start { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_start}->{details}]; +} + +sub render_exit { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_exit}->{details}]; +} + +sub render_end { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', "Job completed at " . $f->{harness_job_end}->{stamp}]; +} + +sub render_control { + my $class = shift; + my ($f, %params) = @_; + + my @out; + + push @out => ['control', 'HALT', $f->{control}->{details}] + if defined $f->{control}->{halt}; + + return @out unless $params{super_verbose}; + + push @out => ['control', 'ENCODING', $f->{control}->{encoding}] + if $f->{control}->{encoding}; + + return @out if @out; + + return ['control', 'CONTROL', $f->{control}->{details}] + if defined $f->{control}->{details}; + + return; +} + +my %SHOW_BRIEF_TAGS = ( + 'CRITICAL' => 1, + 'DEBUG' => 1, + 'DIAG' => 1, + 'ERROR' => 1, + 'FAIL' => 1, + 'FAILED' => 1, + 'FATAL' => 1, + 'HALT' => 1, + 'PASSED' => 1, + 'REASON' => 1, + 'STDERR' => 1, + 'TIMEOUT' => 1, + 'WARN' => 1, + 'WARNING' => 1, + 'KILL' => 1, + 'SKIPPED' => 1, +); + +my %SHOW_BRIEF_FACETS = ( + control => 1, + error => 1, + trace => 1, +); + +sub render_brief { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + if ($f->{render} && @{$f->{render}}) { + my @show = grep { $SHOW_BRIEF_TAGS{uc($_->{tag})} || $SHOW_BRIEF_FACETS{lc($_->{facet})} } @{$f->{render}}; + return [map { [$_->{facet}, uc($_->{tag}), $_->{details}] } @show]; + } + + my @out; + + push @out => $class->render_control($f) if $f->{control}; + + if ($f->{assert} && !$f->{assert}->{pass} && !$f->{amnesty}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{no_debug}; + } + + if ($f->{info}) { + my $if = {%$f, info => [grep { $_->{debug} || $_->{important} } @{$f->{info}}]}; + push @out => $class->render_info($if) if @{$if->{info}}; + } + + push @out => $class->render_errors($f) if $f->{errors}; + + return \@out; +} + +sub render_plan { + my $class = shift; + my ($f) = @_; + + my $plan = $f->{plan}; + return ['plan', 'NO PLAN', $f->{plan}->{details}] if $plan->{none}; + + if ($plan->{skip}) { + return ['plan', 'SKIP ALL', $f->{plan}->{details}] + if $f->{plan}->{details}; + + return ['plan', 'SKIP ALL', "No reason given"]; + } + + return ['plan', 'PLAN', "Expected assertions: $f->{plan}->{count}"]; +} + +sub render_assert { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details} || '<UNNAMED ASSERTION>'; + + return ['assert', '! PASS !', $name] + if $f->{amnesty} && @{$f->{amnesty}}; + + return ['assert', 'PASS', $name] + if $f->{assert}->{pass}; + + return ['assert', 'FAIL', $name] +} + +sub render_amnesty { + my $class = shift; + my ($f) = @_; + + my %seen; + return map { + $seen{join '' => @{$_}{qw/tag details/}}++ + ? () + : ['amnesty', $_->{tag}, $_->{details}] + } @{$f->{amnesty}}; +} + +sub render_debug { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug; + if ($trace) { + $debug = $trace->{details}; + if(!$debug && $trace->{frame}) { + my $frame = $trace->{frame}; + $debug = "$frame->[1] line $frame->[2]"; + } + } + + $debug ||= "[No trace info available]"; + + chomp($debug); + + return ['trace', 'DEBUG', $debug]; +} + +sub render_info { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details} // ''; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + ['info', $_->{tag}, $details, $_->{table} || ()] + } @{$f->{info}}; +} + +sub render_about { + my $class = shift; + my ($f) = @_; + + return if $f->{about}->{no_display}; + return unless $f->{about} && $f->{about}->{details}; + + my $type; + if ($f->{about}->{package}) { + my $type = $f->{about}->{package}; + $type =~ s/^.*:://; + } + $type //= 'ABOUT'; + + return ['about', $type, $f->{about}->{details}]; +} + +sub render_errors { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + my $tag = $_->{tag} || ($_->{fail} ? 'FATAL' : 'ERROR'); + + ['error', $tag, $details] + } @{$f->{errors}}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2::Composer - Compose output components from event facets + +=head1 DESCRIPTION + +This is used by L<Test2::Formatter::Test2> to turn events into output +components. This logic lives here instead of in the formatter because it is +also used by L<Test2::Harness::UI>. Other tools may also find this conversion +useful. + +=head1 SYNOPSIS + + use Test2::Formatter::Test2::Composer; + + # Note, all methods are class methods, this is just here for convenience. + my $comp = Test2::Formatter::Test2::Composer->new(); + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + ... + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=head1 METHODS + +All methods are class methods, but they also work just fine on a blessed +instance. There is no benefit to a blessed instance, but you can create one for +convenience if it makes you more comfortable. + +=over 4 + +=item $inst = $class->new() + +Create a blessed instance. This is here for convenience only. All methods are +class methods. + +=item $arrayref = $class->render_one_line($event) + +=item $arrayref = $class->render_one_line(\%facet_data) + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + +This will return a single line of output from the event, even if the event +would normally return multiple lines. + +In order of priority: + +=over 4 + +=item Custom 'render' facet + +=item Control 'halt' facet (bail-out) + +=item Assertion (pass/fail) + +=item Error message + +=item Plan + +=item Info (note/diag) + +=item Timing data + +=item About + +=back + +=item @lines = $class->render_verbose($event, %control_params) + +=item @lines = $class->render_verbose(\%facet_data, %control_params) + +This will verbosely render any event. The C<%control_params> are passed +directly to C<render_control()> and are not used for anything else. + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=item @lines = $class->render_super_verbose($event) + +=item @lines = $class->render_super_verbose(\%facet_data) + +This is even more verbose than C<render_verbose()> because it produces output +lines even for facets that should normally not be seen, things that would +usually be considered noise. + +This is mainly useful for tools that allow deep inspection of log files. + +=back + +=head2 FACET RENDERERS + +With exception of C<render_control()> these are all the same. These all take +C<\%facet_data> as their only argument, and return a list of line-arrayrefs +C<[$facet, $tag, $text_for_humans]>. + +=over 4 + +=item @lines = $class->render_control(\%facet_data, super_verbose => $bool) + +This specific one is special in that it can take an extra argument. This +argument is used to toggle between super_verbose and regular verbosity. No +other facet renderer needs this toggle. If omitted it defaults to not being +super verbose. + +=item @lines = $class->render_launch(\%facet_data) + +=item @lines = $class->render_start(\%facet_data) + +=item @lines = $class->render_exit(\%facet_data) + +=item @lines = $class->render_end(\%facet_data) + +=item @lines = $class->render_brief(\%facet_data) + +=item @lines = $class->render_plan(\%facet_data) + +=item @lines = $class->render_assert(\%facet_data) + +=item @lines = $class->render_amnesty(\%facet_data) + +=item @lines = $class->render_debug(\%facet_data) + +=item @lines = $class->render_info(\%facet_data) + +=item @lines = $class->render_about(\%facet_data) + +=item @lines = $class->render_errors(\%facet_data) + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness.pm b/libold2/Test2/Harness.pm new file mode 100644 index 000000000..de5d06345 --- /dev/null +++ b/libold2/Test2/Harness.pm @@ -0,0 +1,60 @@ +package Test2::Harness; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness - A new and improved test harness with better L<Test2> +integration. + +=head1 DESCRIPTION + +Test2::Harness is the backend code that handles running/processing the tests. +In general a user will not use it directly, instead you should probably be +looking at L<App::Yath> which is the UI layer built around Test2::Harness. + +=head1 SEE ALSO + +The primary documentation can be found in L<App::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Aggregator.pm b/libold2/Test2/Harness/Aggregator.pm new file mode 100644 index 000000000..a606f99c5 --- /dev/null +++ b/libold2/Test2/Harness/Aggregator.pm @@ -0,0 +1,134 @@ +package Test2::Harness::Aggregator; +use strict; +use warnings; + +use Carp qw/croak/; +use POSIX qw/mkfifo/; + +use Test2::Harness::Util::JSON qw/encode_json/; + +use Atomic::Pipe; +use Test2::Harness::Util::File::Stream; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + -fifo_file + -output_file + -run_id + -name + <made_fifo +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" unless defined($self->{+RUN_ID}); + + croak "'name' is a required attribute" unless $self->{+NAME}; + croak "'fifo_file' is a required attribute" unless $self->{+FIFO_FILE}; + croak "'output_file' is a required attribute" unless $self->{+OUTPUT_FILE}; +} + +sub run { + my $self = shift; + my ($parent_pid) = @_; + + my $outfh = Test2::Harness::Util::File::Stream->new(name => $self->{+OUTPUT_FILE}); + $outfh->write(); # Touch the file + + my $sig = 0; + + my $run_id = $self->{+RUN_ID}; + + my $ok = eval { + $SIG{__WARN__} = sub { + print STDERR @_; + $outfh->write(encode_json({ + facet_data => { + harness => {run_id => $run_id}, + info => [ + {tag => 'AGG WARN', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + }; + + my $fifo; + + local $SIG{INT} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGINT\n"; + $sig = 'INT'; + $fifo->blocking(0) if $fifo; + }; + + local $SIG{TERM} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGTERM\n"; + $sig = 'TERM'; + $fifo->blocking(0) if $fifo; + }; + + mkfifo($self->{+FIFO_FILE}, 0700) or die "Failed to create fifo ($self->{+FIFO_FILE}): $!"; + $self->{+MADE_FIFO} = $$; + + $fifo = Atomic::Pipe->read_fifo($self->{+FIFO_FILE}); + $fifo->resize($fifo->max_size); + + while (1) { + $fifo->blocking(0) if $sig; + + my $event = $fifo->read_message; + + if ($sig && !$event) { + $outfh->write(encode_json({ + facet_data => { + harness => {run_id => $run_id}, + info => [ + {tag => "AGG SIG", details => "(AGGREGATOR) got SIG${sig}"}, + ], + } + }) . "\n"); + $outfh->write("null\n"); + last; + } + + chomp($event); + + next if $event eq 'null'; + + if ($event eq 'TERMINATE') { + $outfh->write("null\n"); + last; + } + + $outfh->write("$event\n"); + } + + 1; + }; + my $err = $@; + + kill($sig, $$) if $sig; + + return 0 if $ok; + + print STDERR $err; + $outfh->write(encode_json({ + facet_data => { + harness => {run_id => $run_id}, + info => [ + {tag => 'AGG DIED', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + + return 255; +} + +sub DESTROY { + my $self = shift; + return unless $self->{+MADE_FIFO}; + return unless $$ == $self->{+MADE_FIFO}; + + eval { unlink($self->{+FIFO_FILE}) or warn "Could not delete fifo: $!"; 1 } or warn "Could not delete fifo: $@"; +} diff --git a/libold2/Test2/Harness/Auditor.pm b/libold2/Test2/Harness/Auditor.pm new file mode 100644 index 000000000..c594246e5 --- /dev/null +++ b/libold2/Test2/Harness/Auditor.pm @@ -0,0 +1,176 @@ +package Test2::Harness::Auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Time::HiRes qw/time/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use Test2::Harness::Event; +use Test2::Harness::Auditor::Watcher; + +use Test2::Harness::Util::HashBase qw{ + <action + <run_id + + +broken + + <watchers + <queued +}; + +sub init { + my $self = shift; + + $self->{+WATCHERS} //= {}; +} + +sub process { + my $self = shift; + + while (my $line = <STDIN>) { + my $data = decode_json($line); + last unless defined $data; + my $e = Test2::Harness::Event->new($data); + + # If process_event does not return anything we need to record just this + # event. If it does return then we want to record what it returns. + if (my @events = $self->process_event($e)) { + $self->{+ACTION}->($_) for @events; + } + else { + $self->{+ACTION}->($e); + } + } +} + +sub process_event { + my $self = shift; + my ($e) = @_; + + my $job_id = $e->job_id; + my $job_try = $e->job_try // 0; + + # Do nothing for non-job events + return $e unless $job_id; + + my $f = $e->facet_data; + + if (my $task = $f->{harness_job_queued}) { + $self->{+WATCHERS}->{$job_id} //= []; + $self->{+QUEUED}->{$job_id} //= $task; + return $e; + } + + my $tries = $self->{+WATCHERS}->{$job_id} or return $self->broken($e, "Never saw queue entry"); + + if (my $job = $f->{harness_job}) { + $tries->[$job_try] = Test2::Harness::Auditor::Watcher->new(job => $job, try => $job_try); + } + + my $watcher = $tries->[$job_try] or return $self->broken($e, "never saw harness_job facet"); + + return $watcher->process($e); +} + +sub broken { + my $self = shift; + my ($e, $message) = @_; + + $self->{+BROKEN}->{$e->job_id}++; + + push @{$e->facet_data->{errors} //= []} => {details => $message, fail => 1}; + + return $e; +} + +sub finish { + my $self = shift; + + my $final_data = {pass => 1}; + + while (my ($job_id, $watchers) = each %{$self->{+WATCHERS}}) { + my $file = File::Spec->abs2rel($self->{+QUEUED}->{$job_id}->{file}); + + if (@$watchers) { + push @{$final_data->{failed}} => [$job_id, $file, $watchers->[-1]->failed_subtest_tree] if $watchers->[-1]->fail; + push @{$final_data->{retried}} => [$job_id, scalar(@$watchers), $file, $watchers->[-1]->pass ? 'YES' : 'NO'] if @$watchers > 1; + + if (my $halt = $watchers->[-1]->halt) { + push @{$final_data->{halted}} => [$job_id, $file, $halt]; + } + } + else { + push @{$final_data->{unseen}} => [$job_id, $self->{+QUEUED}->{$job_id}->{file}]; + } + } + + $final_data->{pass} = 0 if $final_data->{failed} or $final_data->{unseen}; + + my $e = Test2::Harness::Event->new( + job_id => 0, + stamp => time, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => {harness_final => $final_data}, + ); + + $self->{+ACTION}->($e); + $self->{+ACTION}->(undef); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor - Auditor that validates test results by processing an +event stream. + +=head1 DESCRIPTION + +The auditor is responsible for taking a stream of events and determining what +is passing or failing. An L<Test2::Harness::Auditor::Watcher> instance is +created for every job_id seen, and events for each job are passed to the proper +watcher for state management. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Collector.pm b/libold2/Test2/Harness/Collector.pm new file mode 100644 index 000000000..7b9d04dd8 --- /dev/null +++ b/libold2/Test2/Harness/Collector.pm @@ -0,0 +1,436 @@ +package Test2::Harness::Collector; +use strict; +use warnings; + +use Carp qw/croak cluck/; +use POSIX ":sys_wait_h"; +use Time::HiRes qw/time/; +use Scalar::Util qw/reftype/; + +use Test2::Harness::Util qw/parse_exit apply_encoding/; +use Test2::Harness::Util::IPC qw/swap_io/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use IO::Select; +use Scope::Guard; +use Atomic::Pipe; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + event_cb + merge_outputs + +buffer + state + children + + -run_id + -job_id + -job_try + + +clean +}; + +sub init { + my $self = shift; + + croak "'state' is a required attribute" + unless $self->{+STATE}; + + croak "'event_cb' is a required attribute" + unless $self->{+EVENT_CB}; + + my $type = reftype($self->{+EVENT_CB}) // ''; + croak "'event_cb' must be a coderef, got '$self->{+EVENT_CB}'" + unless $type eq 'CODE'; + + $self->{+CHILDREN} //= {}; + $self->{+MERGE_OUTPUTS} //= 0; + + $self->{+RUN_ID} //= 0; + $self->{+JOB_ID} //= 0; + $self->{+JOB_TRY} //= 0; +} + +sub DESTROY { + my $self = shift; + + $self->cleanup_proc; + + return unless $self->{+CHILDREN}; + for my $pid (keys %{$self->{+CHILDREN}}) { + next unless $$ == $self->{+CHILDREN}->{$pid}; + cluck("Failed to reap children parent process $$ when collector instance was destroyed"); + return $self->reap; + } +} + +sub reap { + my $self = shift; + my (@pids) = @_; + + unless (@pids) { + @pids = grep {$$ == $self->{+CHILDREN}->{$_}} keys %{$self->{+CHILDREN} // {}}; + } + return unless @pids; + + my @out; + + for my $pid (@pids) { + croak "$pid is not owned by this collector" + unless $self->{+CHILDREN}->{$pid} && $$ == $self->{+CHILDREN}->{$pid}; + + delete $self->{+CHILDREN}->{$pid}; + + my $check = waitpid($pid, 0); + my $exit = parse_exit($? // 0); + if ($check == $pid) { + push @out => $exit; + warn "Collector exited with a non-zero status (ERR: $exit->{err}, SIG: $exit->{sig})" if $exit->{all}; + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + delete $data->processes->{$pid}; + } + ); + } + else { + die("waitpid returned $check"); + } + } + + return @out; +} + +sub _warn { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + my $cb = $self->{+EVENT_CB}; + $self->_pre_event( + stream => 'process', + stamp => time, + event => { + facet_data => { + info => [{tag => 'WARNING', details => $msg, debug => 1}], + trace => {frame => \@caller} + }, + }, + ); +} + +sub _die { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + $self->_pre_event( + stream => 'process', + stamp => time, + event => { + facet_data => { + errors => [{tag => 'ERROR', details => $msg, fail => 1}], + trace => {frame => \@caller}, + }, + }, + ); + + exit(255); +} + +sub run { + my $self = shift; + my %params = @_; + + my $name = $params{name} or croak "'name' is a required argument"; + my $type = $params{type} or croak "'type' is a required argument"; + my $launch_cb = $params{launch_cb} or croak "'launch_cb' is a required argument"; + my $env = $params{env}; + + my $parent = $params{parent_pid}; + + if (!$parent) { + $parent = $$; + my $collector_pid = fork // CORE::die("Could not fork: $!"); + + if ($collector_pid) { + $self->{+CHILDREN}->{$collector_pid} = $$; + return $collector_pid; + } + + } + + $0 = "Yath-Collector $name"; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$} = {type => 'collector', parent => $parent, pid => $$, name => $name}; + }); + + my ($out_r, $out_w) = Atomic::Pipe->pair(mixed_data_mode => 1); + my ($err_r, $err_w) = $self->{+MERGE_OUTPUTS} ? ($out_r, $out_w) : Atomic::Pipe->pair(mixed_data_mode => 1); + + my $child_pid = fork // CORE::die("Could not fork: $!"); + + if (!$child_pid) { + $0 = $name; + swap_io(\*STDOUT, $out_w->wh, sub { $self->_die(@_) }); + swap_io(\*STDERR, $err_w->wh, sub { $self->_die(@_) }); + + $ENV{T2_HARNESS_USE_ATOMIC_PIPE} = $self->{+MERGE_OUTPUTS} ? 1 : 2; + { + no warnings 'once'; + $Test2::Harness::STDOUT_APIPE = $out_w; + $Test2::Harness::STDERR_APIPE = $err_w unless $self->{+MERGE_OUTPUTS}; + } + + if ($env) { + $ENV{$_} = $env->{$_} for keys %$env; + } + + eval { $launch_cb->(); 1 } or $self->_die($@ // "launch exception"); + + $self->_die("launch-cb returned, it should not do that!"); + } + + $self->_die("Failed to launch child '$type': '$name'") unless $child_pid; + + $self->{+CHILDREN}->{$child_pid} = $$; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$}->{children}->{$child_pid} = $child_pid; + $data->processes->{$child_pid} = {type => $type, parent => $$, pid => $child_pid, name => $name}; + }); + + $self->_die("Did not get a PID from launch callback (Did callback fail to exit when done?)") + unless $child_pid; + + my $stamp = time; + $self->_pre_event( + stream => 'process', + stamp => $stamp, + action => 'launch', + launch => { stamp => $stamp, pid => $child_pid }, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + $SIG{INT} = sub { + $self->_warn("$$: Got SIGINT, forwarding to child process $child_pid.\n"); + kill('INT', $child_pid); + $SIG{INT} = 'DEFAULT'; + }; + $SIG{TERM} = sub { + $self->_warn("$$: Got SIGTERM, forwarding to child process $child_pid.\n"); + kill('TERM', $child_pid); + $SIG{TERM} = 'DEFAULT'; + }; + $SIG{PIPE} = 'IGNORE'; + + my $guard = Scope::Guard->new(sub { + eval { $self->_die("Scope Leak inside collector post-fork!") }; + exit(255); + }); + + $out_w->close; + $err_w->close; + + unless (eval { $self->_run(pid => $child_pid, stdout => $out_r, stderr => $err_r); 1 }) { + my $err = $@; + + $self->cleanup_proc; + + eval { + $guard->dismiss(); + $self->_die($err); + }; + + exit(255); + } + + $self->cleanup_proc; + $guard->dismiss(); + exit(0); +} + +sub cleanup_proc { + my $self = shift; + + return 1 if $self->{+CLEAN}; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$} if $data->processes->{$$} && $data->processes->{$$}->{type} eq 'collector'; + }); + + return $self->{+CLEAN} = 1; +} + +sub _run { + my $self = shift; + my %params = @_; + + $self->{+BUFFER} = {seen => {}, stderr => [], stdout => []}; + + my $pid = $params{pid}; + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + + $stdout->blocking(0); + $stderr->blocking(0); + + my $ios = IO::Select->new; + + my %sets = ($stdout->rh => ['stdout', $stdout]); + $ios->add($stdout->rh); + + unless ($self->{+MERGE_OUTPUTS}) { + $sets{$stderr->rh} = ['stderr', $stderr]; + $ios->add($stderr->rh); + } + + my ($exited, $exit); + while (1) { + my $did_work = 0; + + unless ($exited) { + if (my $check = waitpid($pid, WNOHANG)) { + $exit = parse_exit($? // 0); + + delete $self->{+CHILDREN}->{$pid}; + if ($check == $pid) { + $exited = time; + $did_work++; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$}->{children}->{$pid}; + delete $data->processes->{$pid}; + }); + } + else { + die("waitpid returned $check"); + } + } + } + + my $enc; + + my @sets = $ios->can_read(); + + while (@sets) { + for my $io (@sets) { + my ($name, $fh) = @{$sets{$io}}; + + my ($type, $val) = $fh->get_line_burst_or_data; + unless ($type) { + @sets = grep { $_ ne $io } @sets; + next; + } + + $did_work++; + + if ($type eq 'message') { + my $decoded = decode_json($val); + $self->_add_item($name => $decoded); + } + elsif ($type eq 'line') { + chomp($val); + $self->_add_item($name => $val); + } + else { + chomp($val); + die("Invalid type '$type': $val"); + } + } + } + + next if $did_work; + last if $exited; + } + + $self->_flush(); + + $self->_pre_event( + stream => 'process', + stamp => $exited, + action => 'exit', + exit => {exit => $exit, stamp => $exited}, + event => { + facet_data => { + trace => {frame => [__PACKAGE__, __FILE__, __LINE__]}, + }, + }, + ); + + return; +} + +sub _add_item { + my $self = shift; + my ($stream, $val) = @_; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + push @{$buffer->{$stream}} => [time, $val]; + + $self->_flush() unless keys(%$seen); + + return unless ref($val); + + my $event_id = $val->{event_id} or die "Event has no ID!"; + + my $count = ++($seen->{$event_id}); + return unless $count >= ($self->{+MERGE_OUTPUTS} ? 1 : 2); + + $self->_flush(to => $event_id); +} + +sub _flush { + my $self = shift; + my %params = @_; + + my $to = $params{to}; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + for my $stream (qw/stderr stdout/) { + while (1) { + my $set = shift(@{$buffer->{$stream}}) or last; + my ($stamp, $val) = @$set; + if (ref($val)) { + # Send the event, unless it came via STDERR in which case it should only be a hashref with an event_id + $self->_pre_event(stream => $stream, data => $val, stamp => $stamp) + unless $stream eq 'stderr'; + + last if $to && $val->{event_id} eq $to; + } + else { + $self->_pre_event(stream => $stream, line => $val, stamp => $stamp); + } + } + } +} + +sub _pre_event { + my $self = shift; + my (%data) = @_; + + $data{stamp} //= time; + + my $cb = $self->{+EVENT_CB}; + $self->$cb(\%data); +} + +1; diff --git a/libold2/Test2/Harness/Collector/Auditor.pm b/libold2/Test2/Harness/Collector/Auditor.pm new file mode 100644 index 000000000..957cce5bb --- /dev/null +++ b/libold2/Test2/Harness/Collector/Auditor.pm @@ -0,0 +1,570 @@ +package Test2::Harness::Collector::Auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use List::Util qw/first max/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::File::JSON; + +use Test2::Harness::Util qw/hub_truth parse_exit/; + +use Test2::Harness::Log::TimeTracker; + +use Test2::Harness::Event; + +use Test2::Harness::Util::HashBase qw{ + -file + -job_try + -summary_file <previous_summary + -state + -run_id + -job_id + + -assertion_count + -exit + -plan + +fail + -_errors + -_failures + -_sub_failures + -_plans + -nested + -subtests + -numbers + -times + -halt + -failed_subtest_tree +}; + +sub init { + my $self = shift; + + croak "'try' is a required attribute" + unless defined $self->{+JOB_TRY}; + + croak "'file' is a required attribute" + unless defined $self->{+FILE}; + + $self->{+_FAILURES} = 0; + $self->{+_ERRORS} = 0; + $self->{+ASSERTION_COUNT} = 0; + + $self->{+NUMBERS} = {}; + $self->{+TIMES} = Test2::Harness::Log::TimeTracker->new(); + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; +} + +sub pass { !$_[0]->fail } +sub fail { + my $self = shift; + return $self->{+FAIL} if $self->{+FAIL}; + return $self->{+FAIL} = 1 if $self->fail_error_facet_list; + return 0; +} + +sub has_exit { defined $_[0]->{+EXIT} } +sub has_plan { defined $_[0]->{+PLAN} } + +sub audit { + my $self = shift; + my @out = $self->_audit(@_); + + $self->update_summary() if $self->{+SUMMARY_FILE}; + + return @out; +} + +sub update_summary { + my $self = shift; + + my $done = defined($self->{+EXIT}) || defined($self->{halt}); + my $fail = $self->{+_ERRORS} || $self->{+_FAILURES} || $self->{+_SUB_FAILURES} || $self->{+EXIT} || $self->{+HALT}; + $fail ||= $done && $self->fail_error_facet_list; + + $fail = $fail ? 1 : 0; + $done = $done ? 1 : 0; + + my $new; + if ($done) { + $new = { + fail => $fail, + done => $done, + file => $self->{+FILE}, + run_id => $self->{+RUN_ID}, + job_try => $self->{+JOB_TRY}, + job_id => $self->{+JOB_ID}, + exit => $self->{+EXIT}, + halt => $self->{+HALT}, + plan => $self->{+PLAN}, + assertions => $self->{+ASSERTION_COUNT} // 0, + errors => $self->{+_ERRORS} // 0, + failures => $self->{+_FAILURES} // 0, + subtest_failures => $self->{+_SUB_FAILURES} // 0 + }; + } + else { + $new = { + file => $self->{+FILE}, + run_id => $self->{+RUN_ID}, + job_try => $self->{+JOB_TRY}, + job_id => $self->{+JOB_ID}, + fail => $fail, + done => $done, + }; + } + + my $old = $self->{+PREVIOUS_SUMMARY}; + + my $diff = $old ? keys(%$new) != keys(%$old) : 1; + if ($old && !$diff) { + for my $key (qw/fail done/) { + next if defined($old->{$key}) && $new->{$key} == $old->{$key}; + $diff++; + last; + } + } + + return if $old && !$diff; + $self->{+PREVIOUS_SUMMARY} = $new; + + if (my $file = $self->{+SUMMARY_FILE}) { + Test2::Harness::Util::File::JSON->new(name => $file)->write($new); + } + + if (my $state = $self->state) { + $state->transaction(w => sub { + my ($this, $data) = @_; + $data->{jobs}->{$self->{+RUN_ID}}->{$self->{+JOB_ID}}->{$self->{+JOB_TRY}} = $new; + }); + } +} + +sub _audit { + my $self = shift; + my ($event) = @_; + + my $f = $event->{facet_data}; + my $hf = hub_truth($f); + + my $nested = $hf->{nested} || 0; + + $self->times->process($event, $f, $self->{+ASSERTION_COUNT}) unless $nested; + + return if $hf->{buffered}; + + my $is_ours = $nested == $self->{+NESTED}; + + return unless $is_ours || $f->{from_tap}; + + # Add parent if we start a buffered subtest + if ($f->{harness} && $f->{harness}->{subtest_start}) { + my $st = $self->{+SUBTESTS}->{$nested + 1} ||= {}; + $st->{event} = $event; + $f->{harness_auditor}->{no_render} = 1; + return; + } + + my @out; + + # Not actually a subtest end, someone printed to STDOUT + if ($f->{from_tap} && $f->{harness}->{subtest_end} && !($self->{+SUBTESTS} && keys %{$self->{+SUBTESTS}})) { + # Alter $f so that this incorrect event is not sent to the renderer. + $f->{harness_auditor}->{no_render} = 1; + + # Make a new $f and $event for the rest of the processing. + $f = { + %{$f}, + harness_auditor => {added_by_auditor => 1}, + parent => undef, + trace => undef, + harness => { + %{$f->{harness} || {}}, + subtest_end => undef, + }, + info => [ + @{$f->{info} || []}, + { + details => $f->{from_tap}->{details}, + tag => $f->{from_tap}->{source} || 'STDOUT', + from_harness => 1, + } + ], + }; + + $event = Test2::Harness::Event->new(stamp => time, job_try => $self->{+JOB_TRY}, facet_data => $f); + } + + push @out => $event; + + # Close any deeper subtests + if (my $sts = $self->{+SUBTESTS}) { + my @close = sort { $b <=> $a } grep { $_ > $nested } keys %$sts; + + for my $n (@close) { + my $st = delete $sts->{$n}; + my $se = $st->{event} || $event; + + my $fd = $se->{facet_data}; + delete $fd->{harness_auditor}->{no_render}; + $fd->{parent}->{hid} ||= $n; + $fd->{parent}->{children} ||= $st->{children}; + $fd->{harness}->{closed_by} = $event; + $fd->{harness}->{closed_by_eid} = $event->{event_id}; + + my $pn = $n - 1; + + if ($st->{event}) { + if ($pn > $self->{+NESTED}) { + push @{$sts->{$pn}->{children}} => $fd; + } + elsif ($pn == $self->{+NESTED}) { + $self->subtest_process($fd, $se); + push @out => $se; + } + } + else { + push @out => $se if $self->{+NESTED} && $pn == $self->{+NESTED}; + } + } + } + + unless ($is_ours) { + my $st = $self->{+SUBTESTS}->{$nested} ||= {}; + my $fd = {%$f}; + push @{$st->{children}} => $fd; + return @out; + } + + $self->subtest_process($f, $event); + return @out; +} + +sub subtest_process { + my $self = shift; + my ($f, $event) = @_; + + my $closer = delete $f->{harness}->{closed_by}; + $event ||= Test2::Harness::Event->new(facet_data => $f, job_try => $self->{+JOB_TRY}); + + $self->{+NUMBERS}->{$f->{assert}->{number}}++ + if $f->{assert} && $f->{assert}->{number}; + + if ($f->{parent} && $f->{assert}) { + my $name = $f->{assert}->{details} // "unnamed subtest ($f->{trace}->{frame}->[1] line $f->{trace}->{frame}->[2])"; + + my $subauditor = blessed($self)->new(nested => $self->{+NESTED} + 1, file => $self->{+FILE}, job_try => $self->{+JOB_TRY}); + + my $id = 1; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness}->{job_id} ||= $f->{harness}->{job_id}; + $sf->{harness}->{run_id} ||= $f->{harness}->{run_id}; + $sf->{harness}->{event_id} ||= $sf->{about}->{uuid} ||= gen_uuid(); + $subauditor->subtest_process($sf); + } + + my @errors = $subauditor->subtest_fail_error_facet_list(); + + if ($f->{harness}->{subtest_start}) { + push @{$f->{errors}} => {tag => 'REASON', fail => 1, from_harness => 1, details => "Buffered subtest ended abruptly (missing closing brace event)"} + unless $closer && $closer->{facet_data}->{harness}->{subtest_end}; + } + + my $fail = 0; + if (@errors) { + push @{$f->{errors}} => @errors; + $fail = 1; + } + else { + $fail ||= $f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}}); + $fail ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $fail ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + } + + if ($fail) { + $self->{+_SUB_FAILURES}++; + + # Populate the tree up to this subtest + my $tree = $self->{+FAILED_SUBTEST_TREE} //= []; + push @$tree => [$name, $subauditor->{+FAILED_SUBTEST_TREE} // []]; + } + } + + $self->{+ASSERTION_COUNT}++ if $f->{assert}; + + if ($f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}})) { + $self->{+_FAILURES}++; + } + + if ($f->{control} || $f->{errors}) { + my $err ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $err ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + $self->{+_ERRORS}++ if $err; + $self->{+HALT} = $f->{control}->{details} || '1' if $f->{control} && $f->{control}->{halt} && (!$self->{+HALT} || $self->{+HALT} eq '1'); + } + + if ($f->{plan} && !$f->{plan}->{none}) { + $self->{+_PLANS}++; + $self->{+PLAN} = $f->{plan}; + } + + if ($f->{harness_job_exit}) { + $self->{+EXIT} = $f->{harness_job_exit}->{exit}; + + my $file = $self->{+FILE}; + + warn "checking if the job will retry can not be done here!"; + my $end = $f->{harness_job_end} = { + # This has to happen somewhere else. + #retry => $f->{harness_job_exit}->{retry}, + + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + fail => $self->fail(), + stamp => $f->{harness_job_exit}->{stamp}, + }; + + my $plan = $self->plan; + $end->{skip} = $plan->{details} || "No reason given" if $plan && !$plan->{count}; + + my $times = $self->times; + if ($times && $times->useful) { + $end->{times} = $times->data_dump; + push @{$f->{harness_job_fields}} => $times->job_fields; + push @{$f->{info}} => {tag => 'TIME', details => $times->summary, table => $times->table}; + } + + push @{$f->{errors}} => $self->fail_error_facet_list; + } + + return; +} + +sub subtest_fail_error_facet_list { + my $self = shift; + + my @out; + + my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; + my $count = $self->{+ASSERTION_COUNT}; + + my $numbers = $self->{+NUMBERS}; + my $max = max(keys %$numbers); + if ($max) { + for my $i (1 .. $max) { + if (!$numbers->{$i}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was never seen"}; + } + elsif ($numbers->{$i} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was seen more than once"}; + } + } + } + + if (!$self->{+_PLANS}) { + if ($count) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared"}; + } + else { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared, and no assertions were made."}; + } + } + elsif ($self->{+_PLANS} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Too many plans were declared (Count: $self->{+_PLANS})"}; + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Planned for $plan assertions, but saw $self->{+ASSERTION_COUNT}"} + if $plan && $count != $plan; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Subtest failures were encountered (Count: $self->{+_SUB_FAILURES})"} + if $self->{+_SUB_FAILURES}; + + return @out; +} + +sub fail_error_facet_list { + my $self = shift; + + my @out; + + my $incomplete_subtests = values %{$self->{+SUBTESTS}}; + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "One or more incomplete subtests (Count: $incomplete_subtests)"} + if $incomplete_subtests; + + if (my $wstat = $self->{+EXIT}) { + if ($wstat == -1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "The harness could not get the exit code! (Code: $wstat)"}; + } + else { + my $e = parse_exit($wstat); + if ($e->{err}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Err: $e->{err})"}; + } + if ($e->{sig}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $e->{sig})"}; + } + } + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Errors were encountered (Count: $self->{+_ERRORS})"} + if $self->{+_ERRORS}; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion failures were encountered (Count: $self->{+_FAILURES})"} + if $self->{+_FAILURES}; + + push @out => $self->subtest_fail_error_facet_list(); + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::Auditor - Class to monitor events for a single job +and pass judgement on the result . + +=head1 DESCRIPTION + +This module represents a per-job state tracker. This module sees every event +and manages the state produced. In the end this tracker determines if a test +job passed or failed, and why. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::Auditor; + + my $auditor = Test2::Harness::Collector::Auditor->new(); + + for my $event (@events) { + $auditor->process($event); + } + + print "Pass!" if $auditor->pass; + print "Fail!" if $auditor->fail; + +=head1 METHODS + +=over 4 + +=item $int = $auditor->assertion_count() + +Number of assertions that have been seen. + +=item $exit = $auditor->exit() + +If the job has exited this will return the exit value (integer, 0 or greater). +If the job has not exited yet (or at least if the auditor has not seen the exit +event yet) this will return undef. + +=item $bool = $auditor->fail() + +Returns true if the job has failed/is failing. + +=item @error_facets = $auditor->fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $file = $auditor->file + +If the test file is known this will return it (string). This will return undef +if the file is not yet known. + +=item $string = $auditor->halt + +If the test was halted (bail-out) this will contain the human readible reason. + +=item $bool = $auditor->has_exit + +Check if the exit value is known. + +=item $bool = $auditor->has_plan + +Check if a plan has been seen. + +=item $file = $auditor->file + +file that is running + +=item $int = $auditor->nested + +If this auditor represents a subtest this will be an integer greater than 0, +the top-level test is 0. + +=item $hash = $auditor->numbers + +This is an internal state tracking what test numbers have been seen. This is +really only applicable in tests that produced TAP. + +=item $bool = $auditor->pass + +Check if the test job is passing. + +=item $plan_facet = $auditor->plan() + +If the plan facet has been seen this will return it. + +=item $auditor->process($event); + +Modify the state based on the provided event. + +=item $auditor->subtest_fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $times = $auditor->times() + +Retuns the L<Test2::Harness::Log::TimeTracker> instance. + +=item $int = $auditor->try() + +Sometimes a job is run more than once, in those cases this will be an integer +greater than 0 representing the try. 0 is used for the first try. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Collector/IOParser.pm b/libold2/Test2/Harness/Collector/IOParser.pm new file mode 100644 index 000000000..f7720edcf --- /dev/null +++ b/libold2/Test2/Harness/Collector/IOParser.pm @@ -0,0 +1,139 @@ +package Test2::Harness::Collector::IOParser; +use strict; +use warnings; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + -run_id + -job_id + -job_try + -name + -type +}; + +sub init { + my $self = shift; + + croak "'type' is a required attribute" unless $self->{+TYPE}; + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+RUN_ID} //= 0; + $self->{+JOB_ID} //= 0; + $self->{+JOB_TRY} //= 0; + + return $self; +} + +sub parse_io { + my $self = shift; + my ($io) = @_; + + my $stream = $io->{stream} or confess "No Stream!"; + + my $event = $self->get_event($io); + + $self->parse_process_action($io, $event) if $stream eq 'process'; + $self->parse_stream_line($io, $event) if defined $io->{line}; + + $self->normalize_event($io, $event); + + return ($event); +} + +sub normalize_event { + my $self = shift; + my ($io, $event) = @_; + + my $stamp = $event->{stamp} // $event->{facet_data}->{harness}->{stamp} // $io->{stamp} // time; + my $event_id = $event->{event_id} // $event->{facet_data}->{harness}->{event_id} // $io->{event_id} // gen_uuid(); + + my %fields = ( + stamp => $stamp, + event_id => $event_id, + run_id => $self->{+RUN_ID}, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + ); + + for my $field (keys %fields) { + if (defined $event->{$field}) { + die "'$field' mismatch, internal inconsistency." unless $event->{$field} eq $fields{$field}; + } + else { + $event->{$field} = $fields{$field}; + } + + if (defined $event->{facet_data}->{harness}->{$field}) { + die "'$field' mismatch, internal inconsistency." unless $event->{facet_data}->{harness}->{$field} eq $fields{$field}; + } + else { + $event->{facet_data}->{harness}->{$field} = $fields{$field}; + } + } +} + +sub get_event { + my $self = shift; + my ($io) = @_; + + my $event = $io->{event} // $io->{data} // { + stamp => $io->{stamp} // time, + event_id => $io->{event_id} // gen_uuid(), + facet_data => {}, + }; + + delete $io->{event}; + delete $io->{data}; + + return $event; +} + +sub parse_stream_line { + my $self = shift; + my ($io, $event) = @_; + + my $stream = $io->{stream}; + my $ucstream = uc($stream); + + my $text = delete $io->{line}; + + push @{$event->{facet_data}->{info}} => { + details => $text, + tag => $ucstream, + debug => ($ucstream eq 'STDERR' ? 1 : 0), + }; +} + +sub parse_process_action { + my $self = shift; + my ($io, $event) = @_; + + my $action = $io->{action} or return; + my $data = $io->{$action}; + my $name = $self->{+NAME}; + my $type = $self->{+TYPE}; + + if ($action eq 'launch') { + $event->{facet_data}->{launch} = $data; + push @{$event->{facet_data}->{info}} => { + tag => 'PROCESS', + details => "Launched '$type' process `$name`", + }; + } + + if ($action eq 'exit') { + $event->{facet_data}->{exit} = $data; + push @{$event->{facet_data}->{info}} => { + tag => 'PROCESS', + details => "'$type' process `$name` exited with status $data->{exit}->{all}", + debug => $data->{exit}->{all} ? 1 : 0, + }; + } +} + +1; diff --git a/libold2/Test2/Harness/Collector/IOParser/Stream.pm b/libold2/Test2/Harness/Collector/IOParser/Stream.pm new file mode 100644 index 000000000..4220e79c8 --- /dev/null +++ b/libold2/Test2/Harness/Collector/IOParser/Stream.pm @@ -0,0 +1,47 @@ +package Test2::Harness::Collector::IOParser::Stream; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Test2::Harness::Collector::TapParser qw/parse_stdout_tap parse_stderr_tap/; + +use parent 'Test2::Harness::Collector::IOParser'; +use Test2::Harness::Util::HashBase qw{}; + +sub parse_stream_line { + my $self = shift; + my ($io, $event) = @_; + + my $stream = $io->{stream}; + my $text = $io->{line}; + + my $facets = $stream eq 'stdout' ? parse_stdout_tap($text) : parse_stderr_tap($text); + + if ($facets) { + $event->{facet_data} = $facets; + return; + } + + return $self->SUPER::parse_stream_line(@_); +} + +sub parse_process_action { + my $self = shift; + my ($io, $event) = @_; + + $self->SUPER::parse_process_action(@_); + + my $action = $io->{action} or return; + my $data = $io->{$action}; + + if ($action eq 'exit') { + $event->{facet_data}->{harness_job_exit} = { + exit => $data->{exit}->{all}, + stamp => $data->{stamp}, + }; + } +} + + +1; diff --git a/libold2/Test2/Harness/Collector/JobDir.pm b/libold2/Test2/Harness/Collector/JobDir.pm new file mode 100644 index 000000000..cab8cf7d3 --- /dev/null +++ b/libold2/Test2/Harness/Collector/JobDir.pm @@ -0,0 +1,806 @@ +package Test2::Harness::Collector::JobDir; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Errno qw/EMFILE ENFILE/; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Util qw/ipc_separator/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; +use Test2::Harness::Util qw/maybe_read_file open_file apply_encoding/; + +use Test2::Harness::Event; + +use Test2::Harness::Util::File::Stream; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Value; + +use Test2::Harness::Collector::TapParser qw{ + parse_stdout_tap + parse_stderr_tap +}; + +use Test2::Harness::Util::HashBase qw{ + <run_id <job_id <job_try <job_root <runner_pid + <done + + -_ready_buffer + + -_events_files -_events_buffer -_events_indexes -events_dir -_events_seen + + -stderr_file -_stderr_buffer -_stderr_index -_stderr_cg -_stderr_state + -stdout_file -_stdout_buffer -_stdout_index -_stdout_cg -_stdout_state + + -exit_file -_exit_done -_exit_buffer + + -et_file -et_buffer -et_done + -pet_file -pet_buffer -pet_done + + -last_stamp + + -open_errors -open_error_seen +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" + unless $self->{+RUN_ID}; + + croak "'job_id' is a required attribute" + unless $self->{+JOB_ID}; + + croak "'job_root' is a required attribute" + unless $self->{+JOB_ROOT}; + + $self->{+_EVENTS_SEEN} = {}; + + $self->{+_STDOUT_BUFFER} ||= []; + $self->{+_STDERR_BUFFER} ||= []; + $self->{+_EVENTS_BUFFER} ||= {}; + $self->{+_READY_BUFFER} ||= []; + + $self->{+LAST_STAMP} = time(); +} + +sub poll { + my $self = shift; + my ($max) = @_; + + delete $self->{+OPEN_ERRORS}; + + $self->_fill_buffers($max); + + return @{delete $self->{+OPEN_ERRORS}} if $self->{+OPEN_ERRORS}; + + my (@out, @new); + + # If we have a max number of events then we need to pass that along to the + # inner-pollers, but we need to pass around how many MORE we need, this sub + # will return the amount we still need. + # If this finds that we do not need any more it will exit the loop instead + # of returning a number. + my $check = defined($max) + ? sub { + my $want = $max - scalar(@out) - scalar(@new); + return undef if $want < 1; + return $want; + } + : sub { 1 }; + + while (!defined($max) || @out < $max) { + push @new => $self->_poll_streams($check->() // last); + + push @new => $self->_poll_timeouts($check->() // last) if $self->{+ET_BUFFER} || $self->{+PET_BUFFER}; + + # 'exit' MUST come last, so do not even think about grabbing + # them until @new is empty. + # Micro-optimization, 'exit' only ever has 1 thing, so do + # not enter the subs if we do not need to. + push @new => $self->_poll_exit($check->() // last) if !@new && defined $self->{+_EXIT_BUFFER}; + # We need to check if the runner exited BEFORE trying to check the exit value. + + last unless @new; + + push @out => @new; + @new = (); + } + + return map { + my $stamp = $_->{stamp} ? $self->{+LAST_STAMP} = $_->{stamp} : $self->{+LAST_STAMP}; + Test2::Harness::Event->new(stamp => $stamp, %{$_}); + } @out; +} + +sub _poll_streams { + my $self = shift; + my ($max) = @_; + + my $ready = $self->{+_READY_BUFFER}; + return splice(@$ready, 0, $max) unless @$ready < $max; + + my $stdout = $self->{+_STDOUT_BUFFER}; + my $stdout_cg = $self->{+_STDOUT_CG} ||= []; + my $stdout_params = { + buffer => $stdout, + comment_group => $stdout_cg, + tag => 'STDOUT', + debug => 0, + parser => \&parse_stdout_tap, + max => $max, + }; + + my $stderr = $self->{+_STDERR_BUFFER}; + my $stderr_cg = $self->{+_STDERR_CG} ||= []; + my $stderr_params = { + buffer => $stderr, + comment_group => $stderr_cg, + tag => 'STDERR', + debug => 1, + parser => \&parse_stderr_tap, + max => $max, + }; + + my $out_event = $self->_poll_stream($stdout_params); + my $err_event = $self->_poll_stream($stderr_params); + + # Once both stderr and stdout are waiting for an event we should go ahead + # and stick the events into ready. More often than not both streams will be + # waiting for the same event, the read_buffer_event logic will avoid + # duplicates. We want to call it on both buffers because some IPC + # situations can result in both streams waiting for different events. Also + # we need the sync point removed from both buffers so things can continue. + # This is an intentional bottle-neck that keeps STDOUT, STDERR, and the + # Test2 events in sync so that stderr and stdout appear where they should + # (mostly) relative to the events. This is not perfect, but it is as close + # as we can get when recombining 3+ output streams. + if ($out_event && $err_event) { + $self->_poll_streams_ready_buffer_event($stdout); + $self->_poll_streams_ready_buffer_event($stderr); + } + + if ($self->{+_EXIT_DONE} && (!$max || @$ready < $max)) { + # All done, flush the comment groups + $self->_poll_stream_flush_group($stdout_params) if @$stdout_cg; + $self->_poll_stream_flush_group($stderr_params) if @$stderr_cg; + + $self->_poll_streams_flush_events(); + } + + return splice(@$ready, 0, $max); +} + +sub _poll_streams_flush_events { + my $self = shift; + + my $buffers = $self->{+_EVENTS_BUFFER}; + for my $pid (keys %$buffers) { + for my $tid (keys %{$buffers->{$pid}}) { + my $buffer = $buffers->{$pid}->{$tid} or next; + while(my $e = shift @$buffer) { + $e = ref($e) ? $e : decode_json($e); + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); + } + } + } +} + +sub _poll_streams_ready_buffer_event { + my $self = shift; + my ($buffer) = @_; + + my $set = shift @$buffer; + my ($pid, $tid, $sid) = @$set; + + my $seen = $self->{+_EVENTS_SEEN}; + return if $seen->{$tid}->{$pid}->{$sid}; + + my $e = shift @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} or return; + $seen->{$tid}->{$pid}->{$sid} = 1; + + $e = ref($e) ? $e : decode_json($e); + + die "Stream error: Events skipped or recieved out of order ($e->{stream_id} != $sid)" + if $e->{stream_id} != $sid; + + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); +} + +sub _poll_stream_add_event { + my $self = shift; + my ($line, $params) = @_; + + my $parser = $params->{parser}; + my $tag = $params->{tag}; + my $debug = $params->{debug}; + + my $facet_data = $parser->($line); + $facet_data ||= {info => [{details => $line, tag => $tag, debug => $debug}]}; + my $event_id = $facet_data->{about}->{uuid} ||= gen_uuid(); + + push @{$self->{+_READY_BUFFER}} => { + facet_data => $facet_data, + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + }; +} + +sub _poll_stream_flush_group { + my $self = shift; + my ($params) = @_; + + my $comment_group = $params->{comment_group}; + + return unless @$comment_group; + + shift @$comment_group; # Remove the indentation state + + my $line = join "\n" => @$comment_group; + $self->_poll_stream_add_event($line, $params); + @$comment_group = (); +} + +sub _poll_stream_buffer_group { + my $self = shift; + my ($line, $params) = @_; + + return undef unless $line =~ m/^(\s*)#/; + my $indent = $1; + + my $comment_group = $params->{comment_group}; + + if (@$comment_group && $comment_group->[0] ne $indent) { + # If comment indentation has changed we do not want to append to the group + $self->_poll_stream_flush_group($params); + return 1; + } + else { + # Starting a new group + push @$comment_group => $indent; + } + + push @$comment_group => $line; + shift @{$params->{buffer}}; + return 0; +} + +sub _poll_stream { + my $self = shift; + my ($params) = @_; + + my $max = $params->{max}; + my $buff = $params->{buffer}; + my $comment_group = $params->{comment_group}; + + my $added = 0; + while (@$buff && (!$max || $added < $max)) { + my $line = $buff->[0]; + + # Already have an esync waiting + return 1 if ref $line; + + chomp($line); + + my $esync = $self->_poll_stream_process_harness_line($line, $params); + return 1 if $esync; + + # Put 'comment' lines together in a group, IE buffer this until we are done with comments + # get undef if there was no comment to buffer + # get 1 if we had to flush the buffer and start a new one + # get 0 if we did buffer the event, but no flush + my $stat = $self->_poll_stream_buffer_group($line, $params); + if (defined($stat)) { + $added += $stat; + next; + } + + # non-comment line, flush the comment group + if (@$comment_group) { + $self->_poll_stream_flush_group($params); + $added++; + next; + } + + shift @$buff; + $self->_poll_stream_add_event($line, $params); + $added++; + } + + return 0; +} + +sub _poll_stream_process_harness_line { + my $self = shift; + my ($line, $params) = @_; + + my $job_id = $self->{+JOB_ID}; + return undef unless $line =~ s/T2-HARNESS-\Q$job_id\E-(ESYNC|EVENT): (.+)//; + my ($type, $data) = ($1, $2); + + my $esync; + if ($type eq 'ESYNC') { + $esync = [split ipc_separator() => $data]; + } + elsif ($type eq 'EVENT') { + my $event_data = decode_json($data); + my $pid = $event_data->{pid}; + my $tid = $event_data->{tid}; + my $sid = $event_data->{stream_id}; + + push @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} => $event_data; + $esync = [$pid, $tid, $sid]; + } + else { + die "Unexpected harness type: $type"; + } + + # This becomes the esync, anything leftover actually belongs to the + # next line. + my $buff = $params->{buffer}; + $buff->[0] = $esync; + $buff->[1] = defined($buff->[1]) ? $line . $buff->[1] : $line if length $line; + + # Flush any comment group already buffered, an event is a sane + # boundary, not above that partial comments that might be + # interrupted by the sync point will be part of the next group + $self->_poll_stream_flush_group($params); + + return $esync; +} + +my %FILE_MAP = ( + 'stdout' => [STDOUT_FILE, \&open_file], + 'stderr' => [STDERR_FILE, \&open_file], + 'exit' => [EXIT_FILE, 'Test2::Harness::Util::File::Value'], + + 'event_timeout' => [ET_FILE, 'Test2::Harness::Util::File::Value'], + 'post_exit_timeout' => [PET_FILE, 'Test2::Harness::Util::File::Value'], +); + +sub _open_file { + my $self = shift; + my ($file) = @_; + + my $map = $FILE_MAP{$file} or croak "'$file' is not a known job file"; + my ($key, $type) = @$map; + + return $self->{$key} if $self->{$key}; + + my $path = File::Spec->catfile($self->{+JOB_ROOT}, $file); + my $out; + + if (ref $type) { + return undef unless -e $path; + return $self->{$key} = $self->try_open($path => sub { $type->($path, '<') }); + } + + return $self->{$key} = $self->try_open($path => sub { $type->new(name => $path) }); +} + +sub _fill_stream_buffers { + my $self = shift; + my ($max) = @_; + + my $stdout_state = $self->{+_STDOUT_STATE} //= {}; + my $stderr_state = $self->{+_STDERR_STATE} //= {}; + + my $stdout_buff = $self->{+_STDOUT_BUFFER} ||= []; + my $stderr_buff = $self->{+_STDERR_BUFFER} ||= []; + + my $stdout_file = $self->{+STDOUT_FILE} || $self->_open_file('stdout'); + my $stderr_file = $self->{+STDERR_FILE} || $self->_open_file('stderr'); + + return unless $stdout_file && $stderr_file; + + my @sets = grep { defined $_->[0] } ( + [$stdout_file, $stdout_buff, 'io', 'STDOUT', $stdout_state], + [$stderr_file, $stderr_buff, 'io', 'STDERR', $stderr_state], + ); + + return unless @sets; + + # Cache the result of the exists check on success, files can come into + # existence at any time though so continue to check if it fails. + while (1) { + my $added = 0; + my @events_files = $self->events_files(); + for my $set (@events_files, @sets) { + my ($file, $buff, $type, $name, $state) = @$set; + next if $max && @$buff > $max; + + my $pos = tell($file); + my $line = <$file>; + if (defined($line) && ($self->{+_EXIT_DONE} || substr($line, -1) eq "\n")) { + print "\n" if $state && delete $state->{$pos}; + + my $job_id = $self->{+JOB_ID}; + if ($type eq 'io' && $line =~ s/T2-HARNESS-\Q$job_id\E-ENCODING: (.+)\n$//) { + apply_encoding($file, $1); + } + + push @$buff => $line if length($line); + seek($file, 0, 1) if eof($file); # Reset EOF. + $added++; + } + else { + if ($name && defined($line) && $ENV{YATH_INTERACTIVE}) { + my ($fh); + + if ($name eq 'STDOUT') { + $fh = \*STDOUT; + } + elsif ($name eq 'STDERR') { + $fh = \*STDERR; + } + + my $len = length($line); + if (my $check = $state->{$pos}->{len}) { + if ($len != $check) { + delete $state->{$pos}->{done}; + $line = substr($line, $check); + } + else { + $line = "\n[INTERACTIVE] $line"; + } + } + else { + $line = "\n[INTERACTIVE] $line"; + } + + $state->{$pos}->{len} = $len; + + my $stamp = $state->{$pos}->{stamp} //= time; + my $delta = time - $stamp; + + if($delta >= 1 && !$state->{$pos}->{done}) { + $fh->autoflush(1); + + $state->{$pos}->{done} = 1; + print $fh $line; + } + } + seek($file, $pos, 0); + } + } + last unless $added; + } +} + +sub events_files { + my $self = shift; + + my $buff = $self->{+_EVENTS_BUFFER} ||= {}; + my $files = $self->{+_EVENTS_FILES} ||= {}; + + my $dir = File::Spec->catdir($self->{+JOB_ROOT}, 'events'); + return unless -d $dir; + + my $dh; + if ($self->try_open($dir => sub { opendir($dh, $dir) or die $! })) { + for my $file (readdir($dh)) { + next unless '.jsonl' eq substr($file, -6); + + next if $files->{$file}; + + my $path = File::Spec->catfile($dir, $file); + + next if $files->{$file}; + + my $fh = $self->try_open( + $path => sub { [ + split(ipc_separator() => substr(substr($file, 6 + length(ipc_separator())), 0, -6)), + open_file($path, '<'), + ] } + ); + + $files->{$file} = $fh if $fh; + } + } + + return map { [$_->[2] => $buff->{$_->[0]}->{$_->[1]} ||= [], 'jsonl'] } values %$files; +} + +sub try_open { + my $self = shift; + my ($path, $callback) = @_; + + local ($@, $?, $!, $.); + + my $out; + my $ok = eval { + $out = $callback->(); + 1; + }; + my $errno = $!; + my $err = $@; + + return $out if $ok; + + die $@ unless $errno == ENFILE || $errno == EMFILE; + + my $errors = $self->{+OPEN_ERRORS} //= []; + + unless ($self->{+OPEN_ERROR_SEEN}->{$path}++) { + push @$errors => Test2::Harness::Event->new( + stamp => time, + job_id => 0, + job_try => undef, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => { + info => [{ + details => "Could not open '$path', this is NOT FATAL as yath will try again. Errno is '$errno', Exception was: $err", + tag => 'INTERNAL', + important => 1, + }], + } + ); + } + + return undef; +} + +sub _fill_buffers { + my $self = shift; + my ($max) = @_; + # NOTE 1: 'max' will only effect stdout, stderr, and events.jsonl, the + # other files only have 1 value each so they will not eat too much memory. + # + # NOTE 2: 'max' only effects how many items are ADDED to the buffer, not + # how many are in the buffer, that is good enough, poll() will take care of + # the actual event limiting. We only use this here to make sure the buffer + # grows slowly, this is important if max is used to avoid eating memory. We + # still need to add to the buffers each time though in case we are waiting + # for a sync event before we flush. + + # Wait for the directory + return unless -d $self->{+JOB_ROOT}; + + $self->_fill_stream_buffers($max); + + # Do not look for exit until we are done with the other streams + return if $self->{+_EXIT_DONE} || @{$self->{+_STDOUT_BUFFER}} || @{$self->{+_STDERR_BUFFER}} || first { @$_ } map { values %{$_} } values %{$self->{+_EVENTS_BUFFER}}; + + $self->_open_file('event_timeout'); + $self->_open_file('post_exit_timeout'); + + my $found_timeout = 0; + for my $set ([ET_FILE, ET_BUFFER], [PET_FILE, PET_BUFFER]) { + my ($key, $buffer_key) = @$set; + next if $self->{$buffer_key}; + next unless $self->{$key} && $self->{$key}->exists; + $self->{$buffer_key} = $self->{$key}->read_line // next; + $found_timeout++; + } + + return if $found_timeout; + + return if $self->{+OPEN_ERRORS}; + + my $ended = 0; + + # We need to check if the runner exited BEFORE trying to check the exit value. + my $runner_exited = $self->{+RUNNER_PID} && !kill(0, $self->{+RUNNER_PID}); + my $exit_file = $self->{+EXIT_FILE} || $self->_open_file('exit') || return; + return if $self->{+OPEN_ERRORS}; + + if ($exit_file->exists) { + my $line = $exit_file->read_line; + if (defined($line)) { + $self->{+_EXIT_BUFFER} = $line; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + } + elsif ($runner_exited) { + $self->{+_EXIT_BUFFER} = '-1'; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + + return unless $ended; + + # If we found exit we need one last buffer fill on the other sources. + # If we do not do this we have a race condition. Ignore the max for this. + $self->_fill_stream_buffers(); +} + +sub _poll_timeouts { + my $self = shift; + + my @out; + + if (defined $self->{+ET_BUFFER} && !$self->{+ET_DONE}++) { + push @out => $self->_process_timeout_line('event' => $self->{+ET_BUFFER}, <<" EOT"); +Test2::Harness checks for timeouts at a configurable interval, if a test does +not produce any output to stdout or stderr between intervals it will be +forcefully killed under the assumption it has hung. See the '--event-timeout' +option to configure the interval. + EOT + } + + if (defined $self->{+PET_BUFFER} && !$self->{+PET_DONE}++) { + push @out => $self->_process_timeout_line('post-exit' => $self->{+ET_BUFFER}, <<" EOT"); +Sometimes tests will fork and then return. On supported systems Test2::Harness +will start all tests with their own process group and will wait for the entire +group to exit before considering the test done. In these cases Test2::Harness +will poll for output from the process group at a configurable interval, if no +output is produced between intervals the process group will be forcefully +killed. See the '--post-exit-timeout' option to configure the interval. + EOT + } + + return @out; +} + +sub _poll_exit { + my $self = shift; + # Intentionally ignoring the max argument, this only ever returns 1 item, + # and would not be called if max was 0. + + return unless defined $self->{+_EXIT_BUFFER}; + my $value = delete $self->{+_EXIT_BUFFER}; + + return $self->_process_exit_line($value); +} + +sub _process_events_line { + my $self = shift; + my ($event_data) = @_; + + $event_data->{job_id} = $self->{+JOB_ID}; + $event_data->{job_try} = $self->{+JOB_TRY}; + $event_data->{run_id} = $self->{+RUN_ID}; + $event_data->{event_id} ||= $event_data->{facet_data}->{about}->{uuid} ||= gen_uuid(); + + return $event_data; +} + +sub _process_exit_line { + my $self = shift; + my ($value) = @_; + + chomp($value); + + my $stdout = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stdout")); + my $stderr = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stderr")); + + $stdout =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + $stderr =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + + my $event_id = gen_uuid(); + + my ($exit, $err, $sig, $dmp, $stamp, $retry) = (split(/\s+/, $value), '', '', '', '', '', ''); + + $self->{+DONE} = {retry => $retry}; + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id}, + harness_job_exit => { + details => "Test script exited $exit ($err\:$sig)", + exit => $exit, + code => $err, + signal => $sig, + dumped => $dmp, + retry => $retry, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + stdout => $stdout, + stderr => $stderr, + stamp => $stamp, + line => $value, + }, + } + }; +} + +sub _process_timeout_line { + my $self = shift; + my ($type, $buffer, $reason) = @_; + + chomp($buffer //= ''); + my ($stamp, $delta) = split /\s+/, $buffer; + $stamp //= time(); + $delta = defined($delta) ? sprintf('%.4f', $delta) : '??'; + + my $event_id = gen_uuid(); + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id, details => "Timeout ($type)"}, + errors => [ + { + tag => 'TIMEOUT', + details => "A timeout ($type) has occured (after $delta seconds), job was forcefully killed", + fail => 1, + }, + ], + info => [ + { + tag => 'TIMEOUT', + debug => 1, + important => 1, + details => $reason, + }, + ], + } + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::JobDir - Job Directory Parser, read events from an active +jobs output directory. + +=head1 DESCRIPTION + +This module is responsible for reading and parsing a running jobs output +directory. The result is an event stream. + +This module is not intended for external use, it is an implementation detail +and can change at any time. Currently instances of this module are not passed +to any plugins or callbacks. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Collector/TapParser.pm b/libold2/Test2/Harness/Collector/TapParser.pm new file mode 100644 index 000000000..39520ef97 --- /dev/null +++ b/libold2/Test2/Harness/Collector/TapParser.pm @@ -0,0 +1,383 @@ +package Test2::Harness::Collector::TapParser; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer 'Importer' => 'import'; + +our @EXPORT_OK = qw{ + parse_stdout_tap + parse_stderr_tap + parse_tap_line +}; + +sub parse_stdout_tap { + my ($line) = @_; + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{from_tap} = { source => 'STDOUT', details => $line }; + return $facet_data; +} + + +sub parse_stderr_tap { + my ($line) = @_; + + # STDERR only has comments + return unless $line =~ m/^\s*#/; + + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{info}->[-1]->{tag} = 'DIAG'; + $facet_data->{info}->[-1]->{debug} = 1; + $facet_data->{from_tap} = { source => 'STDERR', details => $line }; + + return $facet_data; +} + +sub parse_tap_line { + my ($line) = @_; + return __PACKAGE__->_parse_tap_line($line); +} + +sub _parse_tap_line { + my $class = shift; + my ($line) = @_; + chomp($line); + + my ($lead, $lead_len, $nest, $str) = ('', 0, 0, $line); + if ($line =~ m/^(\s+)\S/) { + $lead = $1; + $str =~ s/^\Q$lead\E//mg; + + $lead =~ s/\t/ /g; + $lead_len = length($lead); + + # indentation other than 0 or a multiple of 4 spaces... not an event + return undef if $lead_len % 4; + + $nest = $lead_len / 4; + } + + my @types = qw/buffered_subtest comment plan bail version/; + for my $type (@types) { + my $sub = "parse_tap_$type"; + my $facet_data = $class->$sub($str) or next; + $facet_data->{trace}->{nested} = $nest; + $facet_data->{hubs}->[0]->{nested} = $nest; + return $facet_data; + } + + return undef; +} + +sub parse_tap_buffered_subtest { + my $class = shift; + my ($line) = @_; + + # End of a buffered subtest. + return {parent => {}, harness => {subtest_end => 1}} if $line =~ m/^\}\s*$/; + + my $facet_data = $class->parse_tap_ok($line) or return undef; + return $facet_data unless $facet_data->{assert}->{details} =~ s/\s*\{\s*$//g; + + $facet_data->{parent} = { + details => $facet_data->{assert}->{details}, + }; + $facet_data->{harness}->{subtest_start} = 1; + + return $facet_data; +} + +sub parse_tap_ok { + my $class = shift; + my ($line) = @_; + + my ($pass, $todo, $skip, $num, @errors); + + return undef unless $line =~ s/^(not )?ok\b//; + $pass = !$1; + + push @errors => "'ok' is not immediately followed by a space." + if $line && !($line =~ m/^ /); + + if ($line =~ s/^(\s*)(\d+)\b//) { + my $space = $1; + $num = $2; + + push @errors => "Extra space after 'ok'" + if length($space) > 1; + } + + # Not strictly compliant, but compliant with what Test-Simple does... + # Standard does not have a todo & skip. + if ($line =~ s/#\s*(todo & skip|todo|skip)(.*)$//i) { + my ($directive, $reason) = ($1, $2); + + push @errors => "No space before the '#' for the '$directive' directive." + unless $line =~ s/\s+$//; + + push @errors => "No space between '$directive' directive and reason." + if $reason && !($reason =~ s/^\s+//); + + $skip = $reason if $directive =~ m/skip/i; + $todo = $reason if $directive =~ m/todo/i; + } + + # Standard says that everything after the ok (except the number) is part of + # the name. Most things add a dash between them, and I am deviating from + # standards by stripping it and surrounding whitespace. + $line =~ s/\s*-\s*//; + + $line =~ s/^\s+//; + $line =~ s/\s+$//; + + my $is_subtest = ($line =~ m/^Subtest:\s*(.*)$/) ? ($1 or 1) : undef; + + my $facet_data = { + assert => { + pass => $pass, + no_debug => 1, + details => $line, + defined $num ? (number => $num) : (), + }, + }; + + $facet_data->{parent} = { + details => $is_subtest, + } if defined $is_subtest; + + push @{$facet_data->{amnesty}} => { + tag => 'SKIP', + details => $skip, + } if defined $skip; + + push @{$facet_data->{amnesty}} => { + tag => 'TODO', + details => $todo, + } if defined $todo; + + push @{$facet_data->{info}} => { + details => $_, + debug => 1, + tag => 'PARSER', + } for @errors; + + return $facet_data; +} + +sub parse_tap_version { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^TAP version\s/; + + return { + about => { + details => $line, + }, + info => [ + { + tag => 'INFO', + debug => 0, + details => $line, + } + ], + }; +} + +sub parse_tap_plan { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ s/^1\.\.(\d+)//; + my $max = $1; + + my ($directive, $reason) = ("", ""); + + if ($max == 0) { + if ($line =~ s/^\s*#\s*//) { + if ($line =~ s/^(skip)\S*\s*//i) { + $directive = uc($1); + $reason = $line; + $line = ""; + } + } + + $directive ||= "SKIP"; + $reason ||= "no reason given"; + } + + my $facet_data = { + plan => { + count => $max, + skip => ($directive eq 'SKIP') ? 1 : 0, + details => $reason, + } + }; + + push @{$facet_data->{info}} => { + details => 'Extra characters after plan.', + debug => 1, + tag => 'PARSER', + } if $line =~ m/\S/; + + return $facet_data; +} + +sub parse_tap_bail { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^Bail out!\s*(.*)$/; + + return { + control => { + halt => 1, + details => $1, + } + }; +} + +sub parse_tap_comment { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^\s*#/; + + $line =~ s/^\s*# ?//msg; + + return { + info => [ + { + details => $line, + tag => 'NOTE', + debug => 0, + } + ] + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::TapParser - Produce EventFacets from a line of TAP. + +=head1 DESCRIPTION + +This module is responsible for reading and processing any TAP output from +tests. Lines of TAP output are processed into L<Test2::Event> facet data. Note +that C<< Test2 -> TAP -> Test2 >> is lossy at the C<< Test2 -> TAP >> step. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::TapParser qw/parse_tap_line/; + + my $facet_data = parse_tap_line("1..1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + plan => { + details => '', + count => 1, + skip => 0, + }, + }, + "Parsed the plan" + ); + + $facet_data = parse_tap_line("# foo"); + is( + $facet_data, + { + trace => { nested => 0 }, + hubs => [ { nested => 0 } ], + info => [ + { + tag => 'NOTE', + details => 'foo', + debug => 0, + }, + ], + }, + + "Parsed the note" + ); + + $facet_data = parse_tap_line("ok 1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + assert => { + no_debug => 1, + pass => 1, + number => '1', + details => '', + }, + }, + "Parsed the assertion" + ); + +=head1 EXPORTS + +=over 4 + +=item $facet_data = parse_tap_line($line) + +Parse a line of TAP. It is assumed to be STDOUT thus all comments are turned +into notes. Using this export will B<NOT> add the usual C<from_tap> facet. It +is better to use one of the other 2 exports. + +=item $facet_data = parse_stdout_tap($line) + +Parse a line of TAP from stdout. + +=item $facet_data = parse_stderr_tap($line) + +Parse a line of TAP from stderr. This will B<ONLY> parse comment lines (ones +that start with a C<#>, which may be indented). All comments will be treated as +diag's, all other lines will be ignored. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Event.pm b/libold2/Test2/Harness/Event.pm new file mode 100644 index 000000000..5f207ce2d --- /dev/null +++ b/libold2/Test2/Harness/Event.pm @@ -0,0 +1,216 @@ +package Test2::Harness::Event; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::JSON qw/encode_json/; + +use Importer 'Test2::Util::Facets2Legacy' => ':ALL'; + +BEGIN { + require Test2::Event; + our @ISA = ('Test2::Event'); + + # Currently the base class for events does not have init(), that may change + if (Test2::Event->can('init')) { + *INIT_EVENT = sub() { 1 } + } + else { + *INIT_EVENT = sub() { 0 } + } +} + +use Test2::Harness::Util::HashBase qw{ + <facet_data + <stream_id + <event_id + <run_id + <job_id + <job_try + <stamp + +json + processed +}; + +sub trace { $_[0]->{+FACET_DATA}->{trace} } +sub set_trace { confess "'trace' is a read only attribute" } + +sub init { + my $self = shift; + + $self->Test2::Event::init() if INIT_EVENT; + + my $data = $self->{+FACET_DATA} || confess "'facet_data' is a required attribute"; + + for my $field (RUN_ID(), JOB_ID(), JOB_TRY(), EVENT_ID()) { + my $v1 = $self->{$field}; + my $v2 = $data->{harness}->{$field}; + + my $d1 = defined($v1); + my $d2 = defined($v2); + + confess "'$field' is a required attribute" + unless $d1 || $d2 || ($field eq +JOB_TRY && !$self->{+JOB_ID}); + + confess "'$field' has different values between attribute and facet data" + if $d1 && $d2 && $v1 ne $v2; + + $self->{$field} = $data->{harness}->{$field} = $v1 // $v2; + } + + delete $data->{facet_data}; + + # Original trace wins. + if (my $trace = delete $self->{+TRACE}) { + $self->{+FACET_DATA}->{trace} //= $trace; + } +} + +sub as_json { $_[0]->{+JSON} //= encode_json($_[0]) } + +sub TO_JSON { + my $out = {%{$_[0]}}; + + $out->{+FACET_DATA} = { %{$out->{+FACET_DATA}} }; + delete $out->{+FACET_DATA}->{harness_job_watcher}; + delete $out->{+FACET_DATA}->{harness}->{closed_by}; + delete $out->{+JSON}; + delete $out->{+PROCESSED}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Event - Subclass of Test2::Event used by Test2::Harness under +the hood. + +=head1 DESCRIPTION + +Test2 tests produce a sequence of events objects L<Test2::Event>. This is a +subclass of those events for use in L<Test2::Harness>. Event non-test tests +which produce TAP output will have the output parsed into these types of +events. + +=head1 SYNOPSIS + +In normal usage ou will never need to create one fo these events yourself. This +documentation assumes you are operating on an existing event C<$event> that the +harness exposed to you via a plugin or similar. + + my $facet_data = $event->facet_data; + my $run_id = $event->run_id; + my $job_id = $event->job_id; + my $job_try = $event->job_try; + my $event_id = $event->event_id; + +=head1 METHODS + +See L<Test2::Event> for methods provided by the base class. + +=over 4 + +=item $hashref = $event->TO_JSON + +Used for json serialization. + +=item $json_string = $event->as_json + +This will return a json representation of the event. Note that this is a lossy +conversion with some harness specific state removed by design. This may even be +a cached copy of the json string that was decoded to produce the original +object. If the string was not cached before it will be cached for all future +calls ignoring any state change to the event. + +The lossy/cached conversion is intended so that events get passed through the +harness pipeline without modifications from one step translating to another. If +you need something extra to go through you need to either replace the event or +create an additional one. + +=item $string = $event->event_id + +Usually a UUID, but not always! + +=item i$hashref = $event->facet_data + +Get the event facet data, this is the meat of the event that hold all the +state. + +=item $string = $event->job_id + +Usually a UUID, but not always! + +=item $int = $event->job_try + +Integer, 0 or greater. Some jobs are run additional times if they fail, this +says which attempt the event is for. The counter starts at 0. + +=item $bool = $event->processed + +This will be true if the event has been process by the harness. Note that this +attibute is not serialized by C<TO_JSON> or C<as_json>. + +=item $string = $event->run_id + +The run id. This is usually a UUID, but not always! + +=item $ts = $event->stamp + +A unix timestamp for when the event was created. + +=item $id = $event->stream_id + +This is an implementation detail of L<Test2::Formatter::Stream>, do not rely on +it. This is used to prevent parsing errors when stream output is nested in +other stream output, which can happen if you are writing tests for the stream +formatter itself. + +=item $trace = $event->trace + +This si a shortcut for C<< $event->facet_data->{trace} >>. The trace data is +essential and used everywhere. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Finder.pm b/libold2/Test2/Harness/Finder.pm new file mode 100644 index 000000000..093dd8f93 --- /dev/null +++ b/libold2/Test2/Harness/Finder.pm @@ -0,0 +1,940 @@ +package Test2::Harness::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use List::Util qw/first/; +use Cwd qw/getcwd/; +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Text::ParseWords qw/quotewords/; + +use Test2::Harness::TestFile; +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <default_search <default_at_search + + <durations <maybe_durations +duration_data <durations_threshold + + <exclude_files <exclude_patterns <exclude_lists + + <no_long <only_long + + <rerun <rerun_modes <rerun_plugin + + search <extensions + + <multi_project + + <changed <changed_only <changes_plugin <show_changed_files <changes_diff + <changes_filter_file <changes_filter_pattern + <changes_exclude_file <changes_exclude_pattern + <changes_include_whitespace <changes_exclude_nonsub + <changes_exclude_loads <changes_exclude_opens +}; + +sub munge_settings {} + +sub init { + my $self = shift; + + $self->{+EXCLUDE_FILES} = { map {( $_ => 1 )} @{$self->{+EXCLUDE_FILES}} } if ref($self->{+EXCLUDE_FILES}) eq 'ARRAY'; + + if (my $plugins = $self->{+RERUN_PLUGIN}) { + for (@$plugins) { + $_ = "App::Yath::Plugin::$_" unless s/^\+// or m/^(App::Yath|Test2::Harness)::Plugin::/; + my $file = mod2file($_); + require $file; + } + } +} + +sub duration_data { + my $self = shift; + my ($plugins, $settings, $test_files) = @_; + + $self->{+DURATION_DATA} //= $self->pull_durations(); + + return $self->{+DURATION_DATA} if $self->{+DURATION_DATA}; + + for my $plugin (@$plugins) { + next unless $plugin->can('duration_data'); + $self->{+DURATION_DATA} = $plugin->duration_data($settings, $test_files) or next; + last; + } + + return $self->{+DURATION_DATA} //= {}; +} + +sub pull_durations { + my $self = shift; + + my $primary = delete $self->{+MAYBE_DURATIONS}; + my $fallback = delete $self->{+DURATIONS}; + + my @args = ( + name => 'durations', + is_json => 1, + http_args => [{headers => {'Content-Type' => 'application/json'}}], + ); + + if ($primary) { + local $@; + + my $durations = eval { $self->_pull_from_file_or_url(source => $primary, @args) } + or print "Could not fetch optional durations '$primary', ignoring...\n"; + + if ($durations) { + print "Found durations: $primary\n"; + return $durations; + } + } + + return $self->_pull_from_file_or_url(source => $fallback, @args) + if $fallback; + + return; +} + +sub add_exclusions_from_lists { + my $self = shift; + + my @lists = ref($self->{+EXCLUDE_LISTS}) eq 'ARRAY' ? @{$self->{+EXCLUDE_LISTS}} : ($self->{+EXCLUDE_LISTS}); + + for my $path (@lists) { + my $content = $self->_pull_from_file_or_url( + source => $path, + name => 'exclusion lists', + ); + + next unless $content; + + for (split(/\r?\n\r?/, $content)) { + $self->{+EXCLUDE_FILES}->{$_} = 1 unless /^\s*#/; + }; + } +} + +sub _pull_from_file_or_url { + my $self = shift; + my %params = @_; + + my $in = $params{source} // croak "No file or url provided"; + my $name = $params{name} // croak "No name provided"; + + my $is_json = $params{is_json}; + + if (my $type = ref($in)) { + return $in if $is_json && ($type eq 'HASH' || $type eq 'ARRAY'); + } + elsif (-f $in) { + if ($is_json) { + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => $in); + return $file->read(); + } + else { + require Test2::Harness::Util::File; + my $f = Test2::Harness::Util::File->new(name => $in); + return $f->read(); + } + } + elsif ($in =~ m{^https?://}) { + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args}; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + my $res = $ht->$meth($in, $args ? (@$args) : ()); + + die "Could not query $name from '$in'\n$res->{status}: $res->{reason}\n$res->{content}\n" + unless $res->{success}; + + return $is_json ? decode_json($res->{content}) : $res->{content}; + } + + die "Invalid $name specification: $in"; +} + +sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + $self->add_exclusions_from_lists() if $self->{+EXCLUDE_LISTS}; + + my $add_changes = 0; + $add_changes ||= $self->{+CHANGED} && @{$self->{+CHANGED}}; + $add_changes ||= $self->{+CHANGED_ONLY}; + $add_changes ||= $self->{+CHANGES_PLUGIN}; + $add_changes ||= $self->{+CHANGES_DIFF}; + + $self->add_changed_to_search($plugins, $settings) if $add_changes; + + my $add_rerun = $self->{+RERUN}; + $self->add_rerun_to_search($plugins, $settings, $add_rerun) if $add_rerun; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + + return $self->find_project_files($plugins, $settings, $self->search); +} + +sub check_plugins { + my $self = shift; + my ($plugins, $settings) = @_; + + my $check_plugins = $plugins; + my $plugin; + if (my $p = $self->{+CHANGES_PLUGIN}) { + $plugin = $p =~ s/^\+// ? $p : "App::Yath::Plugin::$p"; + $check_plugins = [$plugin]; + } + + return $check_plugins // []; +} + +sub get_diff { + my $self = shift; + my ($plugins, $settings) = @_; + + return (file => $self->{+CHANGES_DIFF}) if $self->{+CHANGES_DIFF}; + + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + if ($plugin->can('changed_diff')) { + my ($type, $data) = $plugin->changed_diff($settings); + next unless $type && $data; + + return ($type => $data); + } + } + + return (); +} + +sub find_changes { + my $self = shift; + my ($plugins, $settings) = @_; + + my @listed_changes = @{$self->{+CHANGED}} if $self->{+CHANGED}; + + my ($type, $diff) = $self->get_diff($plugins, $settings); + + my (@found_changes); + if ($type && $diff) { + @found_changes = $self->changes_from_diff($type => $diff, $settings); + } + + unless (@found_changes) { + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + next unless $plugin->can('changed_files'); + + push @found_changes => $plugin->changed_files($settings); + last if @found_changes; + } + } + + my $filter_patterns = @{$self->{+CHANGES_FILTER_PATTERN}} ? $self->{+CHANGES_FILTER_PATTERN} : undef; + my $filter_files = @{$self->{+CHANGES_FILTER_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_FILTER_FILE}}} : undef; + + my $exclude_patterns = @{$self->{+CHANGES_EXCLUDE_PATTERN}} ? $self->{+CHANGES_EXCLUDE_PATTERN} : undef; + my $exclude_files = @{$self->{+CHANGES_EXCLUDE_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_EXCLUDE_FILE}}} : undef; + + my %changed_map; + for my $change (@listed_changes, @found_changes) { + next unless $change; + my ($file, @parts) = ref($change) ? @$change : ($change); + + next if $filter_files && !$filter_files->{$file}; + next if $exclude_files && $exclude_files->{$file}; + next if $filter_patterns && !first { $file =~ m/$_/ } @$filter_patterns; + next if $exclude_patterns && first { $file =~ m/$_/ } @$exclude_patterns; + + @parts = ('*') unless @parts; + $changed_map{$file}{$_} = 1 for @parts; + } + + return \%changed_map; +} + +sub get_capable_plugins { + my $self = shift; + my ($method, $plugins) = @_; + + my %seen; + return grep { $_ && !$seen{$_}++ && $_->can($method) } @$plugins; +} + +sub add_rerun_to_search { + my $self = shift; + my ($plugins, $settings, $rerun) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $modes = $self->{+RERUN_MODES}; + my $mode_hash = { map {$_ => 1} @$modes }; + + my ($grabbed, $data); + for my $p ($self->get_capable_plugins(grab_rerun => [@{$self->{+RERUN_PLUGIN} // []}, @$plugins])) { + ($grabbed, $data) = $p->grab_rerun($rerun, modes => $modes, mode_hash => $mode_hash, settings => $settings); + next unless $grabbed; + + unless ($data && keys %$data) { + print "No files found to rerun.\n"; + exit 0; + } + + last if $grabbed; + } + + unless ($grabbed) { + if ($rerun eq '1') { + $rerun = first { -e $_ } qw{ ./lastlog.jsonl ./lastlog.jsonl.bz2 ./lastlog.jsonl.gz }; + + die "Could not find a lastlog.jsonl(.bz2|.gz) file for re-running, you may need to provide a full path to --rerun=... or --rerun-failed=..." + unless $rerun; + } + + die "'$rerun' is not a valid log file, and no plugin intercepted it.\n" unless -f $rerun; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $rerun, skip_bad_decode => 1); + + my %files; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $f = $event->{facet_data} or next; + + for my $type (qw/seen queued start end/) { + my $field = $type eq 'seen' ? "harness_job" : "harness_job_$type"; + + my $data = $f->{$field} or next; + + my $file = $data->{rel_file} // $data->{run_file} // $data->{file} // $data->{abs_file}; + next unless $file; + + my $ref = $files{$file} //= {}; + $ref->{$type}++; + + $ref->{$data->{fail} ? 'fail' : 'pass'}++ if $type eq 'end'; + $ref->{retry}++ if $data->{is_try}; + } + } + } + + $data = \%files; + } + + my @add = map { $data->{$_}->{add} // $_ } grep { + my $entry = $data->{$_}; + + my $keep = $mode_hash->{all} ? 1 : 0; + $keep ||= 1 if $mode_hash->{failed} && $entry->{fail} && !$entry->{pass}; + $keep ||= 1 if $mode_hash->{retried} && $entry->{retry}; + $keep ||= 1 if $mode_hash->{passed} && $entry->{pass}; + $keep ||= 1 if $mode_hash->{missed} && !$entry->{end}; + + $keep + } sort keys %$data; + + unless (@add) { + print "No files found to rerun.\n"; + exit 0; + } + + push @$search => @add; +} + +sub add_changed_to_search { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $changed_map = $self->find_changes($plugins, $settings); + my $found_changed = keys %$changed_map; + + die "Could not find any changed files.\n" if $self->{+CHANGED_ONLY} && !$found_changed; + + if ($self->{+CHANGED_ONLY}) { + die "Can not add test or directory names when using --changed-only (saw: " . join(", " => @$search) . ")\n" + if @$search; + } + + if ($self->{+SHOW_CHANGED_FILES} && $found_changed) { + print "Found the following changed files:\n"; + for my $file (keys %$changed_map) { + print " $file: ", join(", ", sort keys %{$changed_map->{$file}}), "\n"; + } + } + + my @add; + for my $p ($self->get_capable_plugins(get_coverage_tests => $plugins)) { + for my $set ($p->get_coverage_tests($settings, $changed_map)) { + my $test = ref($set) ? $set->[0] : $set; + + unless (-e $test) { + print STDERR "Coverage wants to run test '$test', but it does not exist, skipping...\n"; + next; + } + + push @add => $set; + } + } + + for my $p ($self->get_capable_plugins(post_process_coverage_tests => $plugins)) { + $p->post_process_coverage_tests($settings, \@add); + } + + if ($self->{+SHOW_CHANGED_FILES} && @add) { + print "Found " . scalar(@add) . " test files to run based on changed files.\n"; + print ref($_) ? " $_->[0]" : " $_\n" for @add; + print "\n"; + } + + push @$search => @add; + + return; +} + +sub changes_from_diff { + my $self = shift; + my ($type, $data, $settings) = @_; + + my $next; + if ($type eq 'lines') { + $next = sub { shift @$data }; + } + elsif ($type eq 'diff') { + my $lines = [split /\n/, $data]; + $next = sub { shift @$lines }; + } + elsif ($type eq 'file') { + die "'$data' is not a valid diff file.\n" unless -f $data; + open(my $fh, '<', $data) or die "Could not open diff file '$data': $!"; + $next = sub { + my $line = <$fh>; + close($fh) unless defined $line; + return $line; + }; + } + elsif ($type eq 'line_sub') { + $next = $data; + } + elsif ($type eq 'handle') { + $next = sub { scalar <$data> }; + } + else { + die "Invalid diff type '$type'"; + } + + my %changed; + + # Only perl can parse perl, and nothing can parse perl diff. What this does + # is take a diff of every file with 100% context so we see the entire file + # with the +, minus, or space prefix. As we scan it we look for subs. We + # track what files and subs we are in. When we see a change we + # {$file}{$sub}++. + # + # This of course is broken if you make a change between + # subs as it will attribute it to the previous sub, however tracking + # indentation is equally flawed as things like heredocs and other special + # perl things can also trigger that to prematurely think we are out of a + # sub. + # + # PPI and similar do a better job parsing perl, but using them and also + # tracking changes from the diff, or even asking them to parse a diff where + # some lines are added and others removed is also a huge hassle. + # + # The current algorith is "good enough", not perfect. + my ($file, $sub, $indent, $is_perl); + while (my $line = $next->()) { + chomp($line); + if ($line =~ m{^(?:---|\+\+\+) ([ab]/)?(.*)$}) { + my $maybe_prefix = $1; + my $maybe_file = $2; + next if $maybe_file =~ m{/dev/null}; + if ($maybe_prefix) { + $file = -f "$maybe_prefix$maybe_file" ? "$maybe_prefix$maybe_file" : $maybe_file; + } + else { + $file = $maybe_file; + } + $is_perl = 1 if $file =~ m/\.(pl|pm|t2?)$/; + $sub = '*'; # Wildcard, changes to the code outside of a sub potentially effects all subs + next; + } + + next unless $file; + + $line =~ m/^( |-|\+)(.*)$/ or next; + my ($prefix, $statement) = ($1, $2); + my $changed = $prefix eq ' ' ? 0 : 1; + + $is_perl = 1 if $statement =~ m/^#!.*perl/; + + if ($statement =~ m/^(\s*)sub\s+(\w+)/) { + $indent = $1 // ''; + $sub = $2; + + # 1-line sub: sub foo { ... } + if ($statement =~ m/}/) { + $changed{$file}{$sub}++ if $changed; + $sub = '*'; + $indent = undef; + next; + } + } + elsif(defined($indent) && $statement =~ m/^$indent\}/) { + $indent = undef; + $sub = "*"; + + # If this is nothing but whitespace and a closing paren we can skip it. + next if $statement =~ m/^\s*\}?\s*$/ && !$self->{+CHANGES_INCLUDE_WHITESPACE}; + } + + next unless $sub; # If sub is empty then we are not even in a file yet + next unless $changed; # If we are not on a changed line no need to add it + unless ($self->{+CHANGES_INCLUDE_WHITESPACE}) { + next if !length($statement); # If there is no statement length then this is whitespace only + next if $statement =~ m/^\s+$/; # Do not care about whitespace only changes + } + + next if $is_perl && $self->{+CHANGES_EXCLUDE_NONSUB} && $sub eq '*'; + + $changed{$file}{$sub}++; + } + + return map {([$_ => sort keys %{$changed{$_}}])} sort keys %changed; +} + + +sub find_multi_project_files { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search // []; + + die "multi-project search must be a single directory, or the current directory" if @$search > 1; + my ($pdir) = @$search; + my $dir = clean_path(getcwd()); + + my $out = []; + my $ok = eval { + chdir($pdir) if defined $pdir; + my $ret = clean_path(getcwd()); + + opendir(my $dh, '.') or die "Could not open project dir: $!"; + for my $subdir (readdir($dh)) { + chdir($ret); + + next if $subdir =~ m/^\./; + my $path = clean_path(File::Spec->catdir($ret, $subdir)); + next unless -d $path; + + chdir($path) or die "Could not chdir to $path: $!\n"; + + for my $item (@{$self->find_project_files($plugins, $settings, [])}) { + push @{$item->queue_args} => ('ch_dir' => $path); + push @$out => $item; + } + } + + chdir($ret); + 1; + }; + my $err = $@; + + chdir($dir); + die $err unless $ok; + + return $out; +} + +sub find_project_files { + my $self = shift; + my ($plugins, $settings, $input) = @_; + + $input //= []; + $plugins //= []; + + my $default_search = [@{$self->default_search}]; + push @$default_search => @{$self->default_at_search} if $settings->check_prefix('run') && $settings->run->author_testing; + + $_->munge_search($input, $default_search, $settings) for @$plugins; + + my $search = @$input ? $input : $self->{+CHANGED_ONLY} ? [] : $default_search; + + die "No tests to run, search is empty\n" unless @$search; + + + my (%seen, @tests, @dirs); + + for my $item (@$search) { + my ($path, $test_params); + + if (ref $item) { + ($path, $test_params) = @$item; + } + else { + my ($type, $data); + ($path, $type, $data) = split /(:<|:@|:=)/, $item, 2; + if ($type && $data) { + $test_params = {}; + if ($type eq ':<') { + $test_params->{stdin} = $data; + } + elsif ($type eq ':@') { + $test_params->{argv} = decode_json($data); + } + elsif ($type eq ':=') { + $test_params->{env} = decode_json($data); + } + } + } + + push @dirs => $path and next if -d $path; + + unless(-f $path) { + my ($actual, $args) = split /=/, $path, 2; + if (-f $actual) { + $path = $actual; + $test_params = {%{$test_params // {}}, argv => [quotewords('\s+', 0, $args)]}; + } + else { + die "'$path' is not a valid file or directory.\n" if @$input; + next; + } + } + + $path = clean_path($path, 0); + $seen{$path}++; + + my $test; + unless (first { $test = $_->claim_file($path, $settings, from => 'listed') } @$plugins) { + $test = Test2::Harness::TestFile->new(file => $path); + } + + if (my @exclude = $self->exclude_file($test)) { + if (@$input) { + print STDERR "File '$path' was listed on the command line, but has been exluded for the following reasons:\n"; + print STDERR " $_\n" for @exclude; + } + + next; + } + + if ($test_params) { + $test->set_input($test_params->{stdin}) if $test_params->{stdin}; + $test->set_test_args($test_params->{argv}) if $test_params->{argv}; + $test->set_env_vars($test_params->{env}) if $test_params->{env}; + } + + push @tests => $test; + } + + if (@dirs) { + require File::Find; + File::Find::find( + { + no_chdir => 1, + wanted => sub { + no warnings 'once'; + + my $file = clean_path($File::Find::name, 0); + + return if $seen{$file}++; + return unless -f $file; + + my $test; + unless(first { $test = $_->claim_file($file, $settings, from => 'search') } @$plugins) { + for my $ext (@{$self->extensions}) { + next unless m/\.\Q$ext\E$/; + $test = Test2::Harness::TestFile->new(file => $file); + last; + } + } + + return unless $test; + return unless $self->include_file($test); + push @tests => $test; + }, + }, + @dirs + ); + } + + my $test_count = @tests; + my $threshold = $settings->finder->durations_threshold // 0; + if ($threshold && $test_count >= $threshold) { + my $start = time; + my $durations = $self->duration_data($plugins, $settings, [map { $_->relative } @tests]); + my $end = time; + if ($durations && keys %$durations) { + printf("Fetched duration data (Took %0.2f seconds)\n", $end - $start); + for my $test (@tests) { + my $rel = $test->relative; + $test->set_duration($durations->{$rel}) if $durations->{$rel}; + } + } + } + + $_->munge_files(\@tests, $settings) for @$plugins; + + return [ sort { $a->rank <=> $b->rank || $a->file cmp $b->file } @tests ]; +} + +sub include_file { + my $self = shift; + my ($test) = @_; + + my @exclude = $self->exclude_file($test); + + return !@exclude; +} + +sub exclude_file { + my $self = shift; + my ($test) = @_; + + my @out; + + push @out => "File has a do-not-run directive inside it." unless $test->check_feature(run => 1); + + my $full = $test->file; + my $rel = $test->relative; + + push @out => 'File is in the exclude list.' if $self->exclude_files->{$full} || $self->exclude_files->{$rel}; + push @out => 'File matches an exclusion pattern.' if first { $rel =~ m/$_/ } @{$self->exclude_patterns}; + + push @out => 'File is marked as "long", but the "no long tests" opition was specified.' + if $self->no_long && $test->check_duration eq 'long'; + + push @out => 'File is not marked "long", but the "only long tests" option was specified.' + if $self->only_long && $test->check_duration ne 'long'; + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Finder - Library that searches for test files + +=head1 DESCRIPTION + +The finder is responsible for locating test files that should be run. You can +subclass the finder and instruct yath to use your subclass. + +=head1 SYNOPSIS + +=head2 USING A CUSTOM FINDER + +To use Test2::Harness::Finder::MyFinder: + + $ yath test --finder MyFinder + +To use Another::Finder + + $ yath test --finder +Another::Finder + +By default C<Test2::Harness::Finder::> is prefixed onto your custom finder, use +'+' before the class name or prevent this. + +=head2 SUBCLASSING + + use parent 'Test2::Harness::Finder'; + use Test2::Harness::TestFile; + + # Custom finders may provide their own options if desired. + # This is optional. + use App::Yath::Options; + option foo => ( + ... + ); + + # This is the main method to override. + sub find_project_files { + my $self = shift; + my ($plugins, $settings, $search) = @_; + + return [ + Test2::Harness::TestFile->new(...), + Test2::Harness::TestFile->new(...), + ..., + ]; + } + +=head1 METHODS + +These are important state methods, as well as utility methods for use in your +subclasses. + +=over 4 + +=item $bool = $finder->multi_project + +True if the C<yath projects> command was used. + +=item $arrayref = $finder->find_files($plugins, $settings) + +This is the main method. This method returns an arrayref of +L<Test2::Harness::TestFile> instances, each one representing a single test to +run. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +B<Note:> In many cases it is better to override C<find_project_files()> in your +subclasses. + +=item $durations = $finder->duration_data + +This will fetch the durations data if any was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +B<Note:> The result is cached, see L<pull_durations()> to refresh the data. + +=item @reasons = $finder->exclude_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This will +return a list of human readible reasons a test file should be excluded. If the +file should not be excluded the list will be empty. + +This is a utility method that verifies the file is not in an exclude +list/pattern. The reasons are provided back in case you need to inform the +user. + +=item $bool = $finder->include_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This is a +convenience method around C<exclude_file()>, it will return true when +C<exclude_file()> returns an empty list. + +=item $arrayref = $finder->find_multi_project_files($plugins, $settings) + +=item $arrayref = $finder->find_project_files($plugins, $settings, $search) + +These do the heavy lifting for C<find_files> + +The default C<find_files()> implementation is this: + + sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + return $self->find_project_files($plugins, $settings, $self->search); + } + +Each one returns an arrayref of L<Test2::Harness::TestFile> instances. + +Note that C<find_multi_project_files()> uses C<find_project_files()> internall, +once per project directory. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +$search is an arrayref of search paths. + +=item $finder->munge_settings($settings, $options) + +A callback that lets you munge settings and options. + +=item $finder->pull_durations + +This will fetch the durations data if ant was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +L<duration_data()> is a cached version of this. This method will refresh the +cache for the other. + +=back + +=head2 FROM SETTINGS + +See L<App::Yath::Options::Finder> for up to date documentation on these. + +=over 4 + +=item $finder->default_search + +=item $finder->default_at_search + +=item $finder->durations + +=item $finder->maybe_durations + +=item $finder->exclude_files + +=item $finder->exclude_patterns + +=item $finder->no_long + +=item $finder->only_long + +=item $finder->search + +=item $finder->extensions + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/IPC.pm b/libold2/Test2/Harness/IPC.pm new file mode 100644 index 000000000..4129c9ee1 --- /dev/null +++ b/libold2/Test2/Harness/IPC.pm @@ -0,0 +1,520 @@ +package Test2::Harness::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX; + +use Config qw/%Config/; +use Carp qw/croak confess/; +use Time::HiRes qw/sleep time/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use Test2::Harness::IPC::Process; + +BEGIN { + my %SIG_MAP; + my @SIGNAMES = split /\s+/, $Config{sig_name}; + my @SIGNUMS = split /\s+/, $Config{sig_num}; + while (@SIGNAMES) { + $SIG_MAP{shift(@SIGNAMES)} = shift @SIGNUMS; + } + + *SIG_MAP = sub() { \%SIG_MAP }; +} + +use Test2::Harness::Util::HashBase qw{ + <pid + <handlers + <procs + <procs_by_cat + <waiting + <wait_time + <started + <sig_count +}; + +sub init { + my $self = shift; + + $self->{+PID} = $$; + + $self->{+PROCS} //= {}; + $self->{+PROCS_BY_CAT} //= {}; + + $self->{+WAIT_TIME} = 0.02 unless defined $self->{+WAIT_TIME}; + + $self->{+HANDLERS} //= {}; + $self->{+HANDLERS}->{CHLD} //= sub { 1 }; + + $self->{+SIG_COUNT} //= 0; +} + +sub start { + my $self = shift; + + my @caller = caller(1); + + return if $self->{+STARTED}; + $self->{+STARTED} = 1; + + $self->check_for_fork(); + + for my $sig (qw/INT HUP TERM CHLD/) { + croak "Signal '$sig' was already set by something else" + if defined $SIG{$sig} + && $SIG{$sig} ne 'IGNORE' + && $SIG{$sig} ne 'DEFAULT'; + $SIG{$sig} = sub { $self->handle_sig($sig) }; + } +} + +sub stop { + my $self = shift; + + $self->wait(all => 1); + + delete $SIG{$_} for qw/INT HUP TERM CHLD/; + + $self->{+STARTED} = 0; +} + +sub set_sig_handler { + my $self = shift; + my ($sig, $sub) = @_; + $self->{+HANDLERS}->{$sig} = $sub; +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + $self->{+SIG_COUNT}++ unless $sig eq 'CHLD'; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->stop(); + exit(SIG_MAP->{$sig}); +} + +sub killall { + my $self = shift; + my ($sig) = @_; + $sig //= 'TERM'; + + $self->check_for_fork(); + + kill($sig, keys %{$self->{+PROCS}}); +} + +sub check_timeouts {} + +sub check_for_fork { + my $self = shift; + + return 0 if $self->{+PID} == $$; + + $self->{+PROCS} = {}; + $self->{+PROCS_BY_CAT} = {}; + $self->{+WAITING} = {}; + $self->{+PID} = $$; + + return 1; +} + +sub _bring_out_yer_dead { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + # Wait on any/all pids + my $found = 0; + while ((my $pid = waitpid(-1, WNOHANG)) > 0) { + my $exit = $?; + die "waitpid returned pid '$pid', but we are not monitoring that one!" unless $procs->{$pid}; + $found++; + $waiting->{$pid} = [$exit, time()]; + } + + return $found; +} + +sub _check_if_dead_yet { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$waiting) { + next if USE_P_GROUPS && kill(0, -$pid); + $found++; + my $args = delete $waiting->{$pid}; + my $proc = delete $procs->{$pid}; + delete $cat_procs->{$proc->category}->{$pid}; + $self->set_proc_exit($proc, @$args); + } + + return $found; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, @args) = @_; + $proc->set_exit($self, @args); +} + +sub _ex_parrots { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$procs) { + next if $waiting->{$pid}; + next if kill(0, $pid); + $found++; + warn "Process $pid vanished!"; + $waiting->{$pid} = [-1, time()]; + } + + return $found; +} + +sub wait { + my $self = shift; + my %params = @_; + + $self->check_for_fork(); + + my $sig_count = $self->{+SIG_COUNT}; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + return 0 unless keys(%$procs) || keys(%$waiting); + + my $cat_total = $params{cat} ? keys %{$cat_procs->{$params{cat}}} : 0; + + my $start = time; + + my $count = 0; + my $found = 0; + while (1) { + $self->check_timeouts; + + $found += $self->_bring_out_yer_dead(); + $found += $self->_check_if_dead_yet(); + + return $found if $self->_wait_done($found, $start, \%params); + + if (my $cat = $params{cat}) { + my $cur_total = keys %{$cat_procs->{$cat}}; + return 0 unless $cur_total; + my $delta = $cat_total - $cur_total; + return $delta if $delta; + } + + # This is expensive, so only do it if we are gonna end up waiting + # anyway If we do find anything here do not bother waiting. + next if $self->_ex_parrots(); + + # Break the loop if we had a signal come in since starting + last if $self->{+SIG_COUNT} > $sig_count; + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "We escaped the wait cycle"; + return $found; +} + +sub _wait_done { + my $self = shift; + my ($found, $start, $params) = @_; + + my $all = keys(%{$self->{+PROCS}}); + return 1 unless $all; + + return 1 if $params->{timeout} && time - $start >= $params->{timeout}; + + return 0 if $all && $params->{all}; + + return 0 if $params->{all_cat} && keys %{$self->{+PROCS_BY_CAT}->{$params->{all_cat}}}; + + return 0 if $params->{block} && !$found; + + # This gets validated outside this loop + return 0 if $params->{cat}; + + return 1; +} + +sub watch_pid { + my $self = shift; + my ($pid) = @_; + + my $proc = Test2::Harness::IPC::Process->new(pid => $pid); + + return $self->watch($proc); +} + +sub watch { + my $self = shift; + my ($proc) = @_; + + $self->check_for_fork(); + + my $pid = $proc->pid or confess "Process has no pid"; + $pid = abs($pid) if USE_P_GROUPS; + + croak "Already watching pid $pid" if exists $self->{+PROCS}->{$pid}; + + $self->{+PROCS}->{$pid} = $proc; + $self->{+PROCS_BY_CAT}->{$proc->category}->{$pid} = $proc; +} + +sub spawn { + my $self = shift; + my ($proc, $params); + if (@_ == 1) { + $proc = shift(@_); + $params = $proc->spawn_params; + } + else { + $params = {@_}; + my $class = $params->{process_class} // 'Test2::Harness::IPC::Process'; + $proc = $class->new(); + } + + croak "No 'command' specified" unless $params->{command}; + + my $caller1 = [caller()]; + my $caller2 = [caller(1)]; + + my $env = $params->{env_vars} // {}; + + $self->check_for_fork(); + + my $pid = run_cmd(env => $env, caller1 => $caller1, caller2 => $caller2, %$params); + $proc->set_pid($pid); + + $self->watch($proc); + return $proc; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC - Base class for modules that control child processes. + +=head1 DESCRIPTION + +This module is the base class for all parts of L<Test2::Harness> that have to +do process management. + +=head1 ATTRIBUTES + +=over 4 + +=item $pid = $ipc->pid + +The root PID of the IPC object. + +=item $hashref = $ipc->handlers + +Custom signal handlers specific to the IPC object. + +=item $hashref = $ipc->procs + +Hashref of C<< $pid => $proc >> where $proc is an instance of +L<Test2::Harness::IPC::Proc>. + +=item $hashref = $ipc->procs_by_cat + +Hashref of C<< $category => { $pid => $proc } >>. + +=item $hashref = $ipc->waiting + +Hashref of processes that have finished, but have not been handled yet. + +This is an implementation detail you should not rely on. + +=item $float = $ipc->wait_time + +How long to sleep between loops when in a wait cycle. + +=item $bool = $ipc->started + +True if the IPC process has started. + +=item $ipc->sig_count + +Implementation detail, used to break wait loops when signals are received. + +=back + +=head1 METHODS + +=over 4 + +=item $ipc->start + +Start the IPC management (Insert signal handlers). + +=item $ipc->stop + +Stop the IPC management (Remove signal handlers). + +=item $ipc->set_sig_handler($sig, sub { ... }) + +Set a custom signal handler. This is a safer version of +C<< local %SIG{$sig} >> for use with IPC. + +The callback will get exactly one argument, the name of the signal that was +recieved. + +=item $ipc->handle_sig($sig) + +Handle the specified signal. Will cause process exit if the signal has no +handler. + +=item $ipc->killall() + +=item $ipc->killall($sig) + +Kill all tracked child process with the given signal. C<TERM> is used if no +signal is specified. + +This will not wait on the processes, you must call C<< $ipc->wait() >>. + +=item $ipc->check_timeouts + +This is a no-op on the IPC base class. This is called every loop of +C<< $ipc->wait >>. If you subclass the IPC class you can fill this in to make +processes timeout if needed. + +=item $ipc->check_for_fork + +This is used a lot internally to check if this is a forked process. If this is +a forked process the IPC object is completely reset with no remaining internal +state (except signal handlers). + +=item $ipc->set_proc_exit($proc, @args) + +Calls C<< $proc->set_exit(@args) >>. This is called by C<< $ipc->wait >>. You +can override it to add custom tasks when a process exits. + +=item $int = $ipc->wait() + +=item $int = $ipc->wait(%params) + +Wait on processes, return the number found. + +Default is non-blocking. + +Options: + +=over 4 + +=item timeout => $float + +If a blocking paremeter is provided this can be used to break the wait after a +timeout. L<Time::HiRes> is used, so timeout is in seconds with decimals. + +=item all => $bool + +Block until B<ALL> processes are done. + +=item cat => $category + +Block until at least 1 process from the category is complete. + +=item all_cat => $category + +Block until B<ALL> processes from the category are complete. + +=item block => $bool + +Block until at least 1 process is complete. + +=back + +=item $ipc->watch($proc) + +Add a process to be monitored. + +=item $proc = $ipc->spawn($proc) + +=item $proc = $ipc->spawn(%params) + +In the first form $proc is an instance of L<Test2::Harness::IPC::Proc> that +provides C<spawn_params()>. + +In the second form the following params are allowed: + +Anything supported by C<run_cmd()> in L<Test2::Harness::Util::IPC>. + +=over 4 + +=item process_class => $CLASS + +Default is L<Test2::Harness::IPC::Process>. + +=item command => $command + +Program command to call. This is required. + +=item env_vars => { ... } + +Specify custom environment variables for the new process. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/IPC/Model.pm b/libold2/Test2/Harness/IPC/Model.pm new file mode 100644 index 000000000..c42d6a2d5 --- /dev/null +++ b/libold2/Test2/Harness/IPC/Model.pm @@ -0,0 +1,48 @@ +package Test2::Harness::IPC::Model; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util::HashBase qw{ + <state <pid <run_id +}; + +sub init { + my $self = shift; + + $self->{+PID} //= $$; + croak "'state' is required" unless $self->{+STATE}; + croak "'run_id' is required" unless $self->{+RUN_ID}; +} + +sub establish_interactive_stdin { + my $self = shift; + + my $fh; + + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + open($fh, '<', $fifo) or die "Could not open fifo '$fifo': $!"; + } + elsif (-t STDIN) { + $fh = \*STDIN; + } + else { + confess "No human input source is available"; + } + + return $fh; +} + +sub get_test_stdout_pair { croak(blessed($_[0]) . '->get_test_stdout_pair() is not implemented') } +sub get_test_stderr_pair { croak(blessed($_[0]) . '->get_test_stderr_pair() is not implemented') } +sub get_test_events_pair { croak(blessed($_[0]) . '->get_test_events_pair() is not implemented') } +sub add_renderer { croak(blessed($_[0]) . '->add_renderer() is not implemented') } +sub render_event { croak(blessed($_[0]) . '->render_event() is not implemented') } + +sub finish {} + +1; diff --git a/libold2/Test2/Harness/IPC/Model/AtomicPipe.pm b/libold2/Test2/Harness/IPC/Model/AtomicPipe.pm new file mode 100644 index 000000000..0eb71c011 --- /dev/null +++ b/libold2/Test2/Harness/IPC/Model/AtomicPipe.pm @@ -0,0 +1,198 @@ +package Test2::Harness::IPC::Model::AtomicPipe; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use POSIX qw/mkfifo/; +use File::Path qw/make_path/; + +use File::Spec; +use Atomic::Pipe; + +use Test2::Util qw/get_tid/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +pair_cache + +renderer_writers +}; + +sub _get_mixed_pair { + my $self = shift; + + my ($r, $w) = Atomic::Pipe->pair(mixed_data_mode => 1); + + $r->resize($r->max_size); + $w->resize($w->max_size); + $w->wh->autoflush(1); + + my %out; + + my (@lines, @data); + my $read = sub { + if ($w) { + $w->close(); + $w = undef; + delete $out{write_ap}; + } + + while (1) { + my ($type, $val) = $r->get_line_burst_or_data; + last unless $type; + + if ($type eq 'message') { + push @data => decode_json($val); + } + elsif ($type eq 'line') { + push @lines => $val; + } + else { + die "Invalid type '$type'"; + } + } + }; + + my $read_line = sub { $read->(); my @out = @lines; @lines = (); return @out }; + my $read_data = sub { $read->(); my @out = @data; @data = (); return @out }; + + %out = ( + read_line => $read_line, + read_data => $read_data, + read_ap => $r, + write_ap => $w, + ); + + return \%out; +} + +sub get_test_stdout_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + return ($bits->{read_line}, $bits->{write_ap}->wh()); +} + +sub get_test_stderr_pair { + my $self = shift; + my ($r, $w) = Atomic::Pipe->pair; + $r->resize($r->max_size); + my $rh = $r->rh; + $rh->blocking(0); + $w->resize($w->max_size); + $w->wh->autoflush(1); + return (sub { <$rh> }, $w->wh()); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + my $writer_sub = sub { + if ($bits->{read_ap}) { + $bits->{read_ap}->close(); + delete $bits->{read_ap}; + delete $bits->{read_line}; + delete $bits->{read_data}; + } + + $bits->{write_ap}->write_message(encode_json($_)) for @_; + }; + + return ($bits->{read_data}, $writer_sub); +} + +sub add_renderer { + my $self = shift; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, 'renderers'); + make_path($path) unless -d $path; + + # Create file for fifo + my $id = gen_uuid(); + my $file = File::Spec->catfile($path, "${id}.fifo"); + + # make fifo + mkfifo($file, 0700) or die "Failed to create fifo"; + + my $r = Atomic::Pipe->read_fifo($file); + $r->resize($r->max_size); + $r->blocking(0); + + # add the fifo to state for future writers + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + my $files = $data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} //= []; + push @$files => $file; + }); + + # return a sub to read the fifo + return sub { + my @out; + while (my $msg = $r->read_message) { + push @out => decode_json($msg); + } + return @out; + }; +} + +sub renderer_writers { + my $self = shift; + + if (my $have = $self->{+RENDERER_WRITERS}) { + return @{$have->{list} //= []} if $have->{pid} == $$ && $have->{tid} == get_tid(); + delete $self->{+RENDERER_WRITERS}; + delete $_->{out_buffer} for @{$have->{list} // []}; + } + + my @list; + for my $ap (@{$self->{+STATE}->data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} // []}) { + my $w = Atomic::Pipe->write_fifo($ap); + $w->resize($w->max_size); + push @list => $w; + } + + $self->{+RENDERER_WRITERS} = { + pid => $$, + tid => get_tid(), + list => \@list, + }; + + return @list; +} + +sub render_event { + my $self = shift; + my ($e) = @_; + + my $json = encode_json($e); + + $_->write_message($json) for $self->renderer_writers; +} + +sub finish { + my $self = shift; + # Blocking flush on all/any renderer handles + + # First flush any that can be flushed without a wait + $_->flush(blocking => 0) for $self->renderer_writers; + + # Terminate the output + $self->render_event(undef); + + # Now we wait and flush all. + for my $ap ($self->renderer_writers) { + $ap->flush(blocking => 1); + $ap->close(); + } +} + +1; diff --git a/libold2/Test2/Harness/IPC/Model/FilePipeHybrid.pm b/libold2/Test2/Harness/IPC/Model/FilePipeHybrid.pm new file mode 100644 index 000000000..7f8870900 --- /dev/null +++ b/libold2/Test2/Harness/IPC/Model/FilePipeHybrid.pm @@ -0,0 +1,56 @@ +package Test2::Harness::IPC::Model::FilePipeHybrid; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use Test2::Harness::IPC::Model::Files; +use Test2::Harness::IPC::Model::AtomicPipe; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + -files + -pipes +}; + +sub init { + my $self = shift; + + $self->{+FILES} //= Test2::Harness::IPC::Model::Files->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); + $self->{+PIPES} //= Test2::Harness::IPC::Model::AtomicPipe->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); +} + +sub get_test_stdout_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stdout_pair(@_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stderr_pair(@_); +} + +sub get_test_events_pair { + my $self = shift; + return $self->{+PIPES}->get_test_events_pair(@_); +} + +sub add_renderer { + my $self = shift; + $self->{+FILES}->add_renderer(@_); +} + +sub render_event { + my $self = shift; + $self->{+FILES}->render_event(@_); +} + +sub finish { + my $self = shift; + $self->{+FILES}->finish(@_); + $self->{+PIPES}->finish(@_); +} + +1; diff --git a/libold2/Test2/Harness/IPC/Model/Files.pm b/libold2/Test2/Harness/IPC/Model/Files.pm new file mode 100644 index 000000000..9851cac3f --- /dev/null +++ b/libold2/Test2/Harness/IPC/Model/Files.pm @@ -0,0 +1,149 @@ +package Test2::Harness::IPC::Model::Files; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use File::Spec; +use File::Path qw/make_path/; + +use Test2::Util qw/get_tid ipc_separator/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Stream; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +render_writer +}; + +sub get_test_stdout_pair { + my $self = shift; + return $self->_get_std_pair(STDOUT => @_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->_get_std_pair(STDERR => @_); +} + +sub _get_std_pair { + my $self = shift; + my ($fname, $job_id, $job_try) = @_; + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, $job_id, $job_try); + + make_path($path) unless -d $path; + + my $file = File::Spec->catfile($path, $fname); + + open(my $wh, '>>', $file) or die "Could not open '$file' for writing: $!"; + + my $rs; + my $read_sub = sub { + $rs //= Test2::Harness::Util::File::Stream->new(name => $file); + $rs->poll(); + }; + + return ($read_sub, $wh); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $reader_sub = $self->_generate_reader(event_files => $job_id, $job_try); + my $writer_sub = $self->_generate_writer(event_files => $job_id, $job_try); + + return ($reader_sub, $writer_sub); +} + +sub add_renderer { + my $self = shift; + return $self->_generate_reader('render_files'); +} + +sub render_event { + my $self = shift; + my ($e) = @_; + my $writer = $self->{+RENDER_WRITER} //= $self->_generate_writer('render_files'); + $writer->($e); +} + +sub _generate_writer { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, $stream, $file) = (0, 0); + my $writer_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + $file = File::Spec->catfile($path, join(ipc_separator(), time, $pid, $tid) . ".jsonl"); + $stream = Test2::Harness::Util::File::JSONL->new(name => $file); + $self->{+STATE}->transaction(w => sub { + my ($state) = @_; + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + push @$files => $file; + }); + } + + $stream->write($_) for @_; + }; +} + +sub _generate_reader { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, %streams) = (0, 0); + my $reader_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + + # Clear stream cache on new proc/thread + %streams = (); + } + + my @events; + + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + for my $file (@$files) { + my $stream = $streams{$file} //= Test2::Harness::Util::File::JSONL->new(name => $file); + push @events => $stream->poll(); + } + + return @events; + }; + + return $reader_sub; +} + +sub _get_file_list { + my $self = shift; + my @path = @_; + my $last = pop @path; + + my $data = $self->{+STATE}->data->ipc_model; + $data = $data->{$_} //= {} for @path; + $data = $data->{$last} //= []; + return $data; +} + +sub finish { + my $self = shift; + $self->render_event(undef); +} + +1; diff --git a/libold2/Test2/Harness/IPC/Process.pm b/libold2/Test2/Harness/IPC/Process.pm new file mode 100644 index 000000000..d15e472be --- /dev/null +++ b/libold2/Test2/Harness/IPC/Process.pm @@ -0,0 +1,134 @@ +package Test2::Harness::IPC::Process; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <exit <exit_time + <pid + +category +}; + +sub category { $_[0]->{+CATEGORY} //= 'default' } + +sub set_pid { + my $self = shift; + my ($pid) = @_; + + croak "pid has already been set" if defined $self->{+PID}; + + $self->{+PID} = $pid; +} + +sub set_exit { + my $self = shift; + my ($ipc, $exit, $time) = @_; + + croak "exit has already been set" if defined $self->{+EXIT}; + + $self->{+EXIT} = $exit; + $self->{+EXIT_TIME} = $time; +} + +sub spawn_params { + my $self = shift; + my $class = ref($self) || $self; + + croak "Process class '$class' does not implement 'spawn_params()'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::Process - Base class for processes controlled by +Test2::Harness::IPC. + +=head1 DESCRIPTION + +All processes controlled by L<Test2::Harness::IPC> should subclass this one. + +=head1 ATTRIBUTES + +=over 4 + +=item $int = $proc->exit + +Exit value, if set. Otherwise C<undef>. + +=item $stamp = $proc->exit_time + +Timestamp of the process exit, if set, otherwise C<undef>. + +=item $pid = $proc->pid + +Pid of the process, if it has been started. + +=item $cat = $proc->category + +Set at construction, C<'default'> if not provided. + +=back + +=head1 METHODS + +=over 4 + +=item $opt->set_pid($pid) + +Set the process id. + +=item $opt->set_exit($ipc, $exit, $time) + +Set the process as complete. $exit should be the exit value. $time should be a +timestamp. $ipc is an instance of L<Test2::Harness::IPC>. + +=item $hashref = $opt->spawn_params() + +Used when spawning the process, args go to C<run_cmd()> from +L<Test2::Harness::Util::IPC>. + +The base class throws an exception if this method is called. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/IPC/SharedState.pm b/libold2/Test2/Harness/IPC/SharedState.pm new file mode 100644 index 000000000..769e302a2 --- /dev/null +++ b/libold2/Test2/Harness/IPC/SharedState.pm @@ -0,0 +1,330 @@ +package Test2::Harness::IPC::SharedState; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Test2::Harness::Util::File::JSON; +use Scalar::Util qw/weaken blessed/; +use Time::HiRes qw/time stat/; +use Carp qw/croak confess/; +use Fcntl qw/:flock/; +use Errno qw/EINTR EAGAIN ESRCH/; + +use Test2::Harness::Util::HashBase qw{ + <state_file <state_fh <state_umask + + <access_id <access_pid <access_meta + <timeout + + +transaction + + <registered <unregistered +}; + +use constant LOCAL => 'local'; +use constant ACCESS => 'access'; + +sub state_class {} + +sub init { + my $self = shift; + + croak "'state_file' is a required attribute" unless $self->{+STATE_FILE}; + + $self->{+TIMEOUT} //= 300; # Timeout runs if they do not update at least every 5 min + $self->{+STATE_UMASK} //= 0007; +} + +sub state { shift->transaction('r') } +sub data { shift->transaction('r') } + +sub init_state { + my $self = shift; + return {timeout => $self->{+TIMEOUT}}; +} + +sub transaction { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $mode //= 'r'; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + croak "mode must be 'w', 'rw', 'r', or 'ro', got '$mode'" unless $write || $read; + + if ($write) { + confess "Write mode requires a 'access_id'" unless $self->access_id; + my $pid = $self->access_pid or confess "Write mode requires a 'access_pid'"; + confess "Access PID mismatch ($pid vs $$)" unless $$ == $pid; + } + + my ($lock, $state, $local, $new); + if ($state = $self->{+TRANSACTION}) { + $new = 0; + $local = $state->{+LOCAL}; + + confess "Attempted a 'write' transaction inside of a read-only transaction" + if $write && !$local->{write}; + } + else { + $new = 1; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $lockf = "$self->{+STATE_FILE}.LOCK"; + + open($lock, '>>', $lockf) or die "Could not open lock file '$lockf': $!"; + while (1) { + last if flock($lock, $write ? LOCK_EX : LOCK_SH); + next if $! == EINTR || $! == EAGAIN; + warn "Could not get lock: $!"; + } + + $state = $self->_read_state(); + 1; + }; + my $err = $@; + umask($oldmask); + die $err unless $ok; + + $local = $state->{+LOCAL} = { + lock => $lock, + mode => $mode, + write => $write, + stack => [{cb => $cb, args => \@args}], + }; + + weaken($state->{+LOCAL}->{lock}); + } + + local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => \@args}]) + if $self->{+TRANSACTION}; + + local $self->{+TRANSACTION} = $state; + + if ($new) { + if ($write) { + if ($self->registered) { + $self->_verify_registration($state); + } + else { + $self->_update_registration($state); + } + } + $self->_clear_old_registrations($state); + } + + my $out; + my $ok = eval { $out = $cb ? $self->$cb($state, @args) : $state; 1 }; + my $err = $@; + + if ($ok && $write && $new) { + $self->_clear_old_registrations($state); + $self->_update_registration($state) unless $self->{+UNREGISTERED}; + $self->_write_state($state); + } + + if ($lock) { + flock($lock, LOCK_UN) or die "Could not release lock: $!"; + } + + die $err unless $ok; + + return $out; +} + +sub _read_state { + my $self = shift; + + return $self->init_state unless -e $self->{+STATE_FILE}; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + + my ($ok, $err, $state); + for (1 .. 5) { + $ok = eval { $state = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.2; + } + + warn "Corrupted state? Resetting state to initial. Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + $state ||= $self->init_state; + + $self->sync_from_state($state); + + my $class = $self->state_class or return $state; + return $state if blessed($state); + return bless($state, $class); +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->{+TIMEOUT} = $state->{timeout}; +} + +sub _write_state { + my $self = shift; + my ($state) = @_; + + my $state_copy = {%$state}; + + my $local = delete $state_copy->{+LOCAL}; + + confess "Attempted write with no lock" unless $local->{lock}; + confess "Attempted write with a read-only lock" unless $local->{write}; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + $file->rewrite($state_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +sub update_registration { $_[0]->transaction(rw => '_update_registration') } +sub remove_registration { $_[0]->transaction(rw => '_update_registration', remove => 1) } + +sub _update_registration { + my $self = shift; + my ($state, %params) = @_; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id} //= { + %{$self->{+ACCESS_META} // {}}, + access_id => $access_id, + access_pid => $self->access_pid, + user => $ENV{USER}, + added => time, + }; + + # Update our last checkin time + $entry->{seen} = time; + + $self->{+REGISTERED} = $$; + + return $state unless $params{remove}; + + $self->{+UNREGISTERED} = 1; + $entry->{remove} = 1; + + return $state; +} + +sub _verify_registration { + my $self = shift; + my ($state) = @_; + + return unless $self->registered; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id}; + + # Do not allow for a new expiration. If the state has already expired us we will see it. + $entry->{seen} = time if $entry; + + return unless $self->{+UNREGISTERED} //= $self->_entry_expired($entry); + + confess "Shared state registration expired"; +} + +sub _entry_expired { + my $self = shift; + my ($entry) = @_; + + return 1 unless $entry; + return 1 if $entry->{remove}; + + if (my $pid = $entry->{+ACCESS_PID}) { + my $ret = kill(0, $pid); + my $err = $!; + return 1 if $ret == 0 && $! == ESRCH; + } + + my $seen = $entry->{seen} or return 1; + my $delta = time - $seen; + + return 1 if $self->{+TIMEOUT} && $delta > $self->{+TIMEOUT}; + + return 0; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $access = $state->{+ACCESS} //= {}; + + my (%removed); + for my $entry (values %$access) { + $entry->{remove} = 1 if $self->_entry_expired($entry); + next unless $entry->{remove}; + + my $access_id = $entry->{access_id}; + + $self->{+UNREGISTERED} = 1 if $access_id eq $self->access_id; + + delete $access->{$access_id}; + + $removed{$access_id}++; + } + + return [keys %removed]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::SharedState - IPC Shared State + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Log.pm b/libold2/Test2/Harness/Log.pm new file mode 100644 index 000000000..87e28677a --- /dev/null +++ b/libold2/Test2/Harness/Log.pm @@ -0,0 +1,289 @@ +package Test2::Harness::Log; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log - Documentation about the L<Test2::Harness> log file. + +=head1 DESCRIPTION + +L<Test2::Harness> aka L<App::Yath> produces a rich/complete log when asked to +do so. This module documents the log format. + +=head1 COMPRESSION + +Test2::Harness can output log files uncompressed, compressed in gzip, or +compressed in bzip2. + +=head1 FORMAT + +The log file is in jsonl format. Each line of the log can be indepentantly +parsed as json. Each line represents a single event Test2::Harness processed +during a run. These events will be in the original order Test2::Harness +processed them in (may not be chronological to when they were generated as +generation, collection, processing, and rendering are handled in different +processes. A complete log will be terminated by the string C<null>, which is +also valid json. If a log is missing this terminator it is considered an +incomplete log. + +=head2 EVENTS + +B<Please note:> Older versions of Test2::Harness produced less complete events, +this covers all current fields, if you are attempting to handle very old logs +some of these fields may be missing. + +Each event will have the following fields: + + { + "event_id" : "CD01CD30-D535-11EA-9B6A-D90F9664FE12", + "job_id" : 0, + "job_try" : null, + "run_id" : "CCF98E54-D535-11EA-915A-D70F9664FE12", + "stamp" : 1596423763.76517, + + "facet_data" : { + "harness" : { + "event_id" : "CD01CD30-D535-11EA-9B6A-D90F9664FE12", + "job_id" : 0, + "job_try" : null, + "run_id" : "CCF98E54-D535-11EA-915A-D70F9664FE12" + }, + + ... + } + } + +=over 4 + +=item event_id : "UUID_OR_STRING" + +Typically this will be a UUID, but when UUIDs cannot be generated it may have a +different unique identifier. This will always be a string. This may never be +NULL, if it is NULL then that is a bug and should be reported. + +=item job_id : "0_OR_UUID_OR_STRING" + +ID C<0> is special in that it represents the test harness itself, and not an +actual test being run. Normally the job_id will be a UUID, but may be another +unique string if UUID generation is disabled or not available. + +=item job_try : INTEGER_OR_NULL + +For C<< job_id => 0 >> this will be C<NULL> for any other job this will be an +intgeger of 0 or greater. This is 0 for the first time a test job is run, if a +job is re-run due to failure (or any other reason) this will be incremented to +tell you what run it is. When a job is re-run it keeps the same job ID, you can +use this to distinguish events from each run of the job. + +=item run_id : "UUID_OR_STRING" + +This is the run_id of the entire yath test run. This should be the same for +every event in any given log. + +=item stamp : UNIX_TIME_STAMP + +Timestamp of the event. This is NORMALLY set when an event is generated, +however if an event does not have its own time stamp yath will give it a +timestamp upon collection. Events without timestamps happen if the test outputs +TAP instead of L<Test2::Event> objects, or if a tool misbehaves in some way. + +=item facet_data : HASH + +This contains all the the data of the event, such as if an assertion was made, +what file name and line number generated it, etc. + +In addition to the original facets of the event, Test2::Harness may inject the +following facets (or generate completely new events to convey these facets). + +=over 4 + +=item harness_final + +This will contain the final summary data from the end of the test run. + + { + # Was the test run a success, or were there failures? + pass => $BOOL, + + # What tests failed? + failed => [ + [ + $job_id, # Job id of the job that failed + $file, # Test filename + ], + ... + ], + + # What tests had to be retried, and did they eventually pass? + retried => [ + [ + $job_id, # Job id of the job that was retied + $tries, # Number of tries attempted + $file, # Test filename + $eventually_passed, # 'YES' if it eventually passed, 'NO' if no try ever passed. + ], + ... + ], + + # What tests sent a halt event (such as bail-out, or skip the rest) + halted => [ + [ + $job_id, # Job id of the test + $file, # Test filename + $halt, # Halt code + ], + ... + ], + + # What tests were never run (maybe because of a bail-out, or an internal error) + unseen => [ + [ + $job_id, # Job id of the test + $file, # Test filename + ], + ... + ], + } + +=item harness_watcher + +Internal use only, subject to change, do not rely on it. + +=item harness_job + +A hash representation of an L<Test2::Harness::Runner::Job> object. + +B<Note:> This is done via a transformation, several methods have their values +stored in this hash when the original object does not directly store them. + +=item harness_job_end + + { + file => $provided_path_to_test_file, + rel_file => $relative_path_to_test_file, + abs_file => $absolute_path_to_test_file, + + fail => $BOOL, + retry => $INTEGER, # Number of retries left + stamp => $UNIX_TIMESTAMP, # Timestamp of when the test completed + + # May not be present + skip => $STRING, # Reason test was skipped (if it was skipped) + times => $TIMING_DATA, # See below + } + +The C<times> field is populated by calling C<data_dump()> on an +L<Test2::Harness::Log::TimeTracker> Object. + +=item harness_job_exit + +This represents when the test job exited. + + { + exit => $WSTAT, + retry => $INTEGER + stamp => $UNIX_TIMESTAMP + } + +=item harness_job_fields + +Extra data attached to the harness job, usually from an +L<Test2::Harness::Plugin> via C<inject_run_data()>. + +=item harness_job_launch + +This facet is almost always in the same event as the C<harness_job_start> +facet. I<NOTE:> While writing these docs the author wonders if this facet is +unnecessary... + + { + stamp => $UNIX_TIMESTAMP, + rety => $INTEGER, + } + + +=item harness_job_queued + +This data is produced by the C<queue_item> method in +L<Test2::Harness::TestFile>. + +This contains the data about a test job conveyed by the queue. This usually +contains data that will later be used by L<Test2::Harness::Runner::Job>. It is +better to use the C<harness_job> facet, which contains the final data used to +run the job. + +The following 3 fields are the only ones likely to be useful to most people: + + { + file => $ORIGINAL_PATH_TO_FILE, + job_id => $UUID_OR_STRING, + stamp => $UNIX_TIMESTAMP, + } + +=item harness_job_start + +This facet is sent in an event as soon as a job starts. The data in this facet +is mainly intended to convey necessary information to a renderer so that it can +render the fact that a job started. + + { + file => $provided_path_to_test_file, + rel_file => $relative_path_to_test_file, + abs_file => $absolute_path_to_test_file, + + stamp => $UNIX_TIMESTAMP, # Timestamp of when the test completed + job_id => $UUID_OR_STRING, + + details => "Job UUID_OR_STRING started at $UNIX_TIMESTAMP", + } + +=item harness_run + +A hash representation of an L<Test2::Harness::Run> object. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Log/CoverageAggregator.pm b/libold2/Test2/Harness/Log/CoverageAggregator.pm new file mode 100644 index 000000000..e3893e7eb --- /dev/null +++ b/libold2/Test2/Harness/Log/CoverageAggregator.pm @@ -0,0 +1,405 @@ +package Test2::Harness::Log::CoverageAggregator; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Find qw/find/; +use Test2::Harness::Util::HashBase qw/<touched <job_map +can_touch +can_start_test +can_stop_test +can_record_coverage <file +io <encode/; + +sub init { + my $self = shift; + $self->{+TOUCHED} //= {}; + $self->{+JOB_MAP} //= {}; + + $self->{+CAN_TOUCH} = !!$self->can('touch'); + $self->{+CAN_START_TEST} = !!$self->can('start_test'); + $self->{+CAN_STOP_TEST} = !!$self->can('stop_test'); + $self->{+CAN_RECORD_COVERAGE} = !!$self->can('record_coverage'); + + if (my $file = $self->{+FILE}) { + open(my $fh, '>', $file) or die "Could not open file '$file' for writing: $!"; + $self->{+IO} = $fh; + } +} + +sub flush { } +sub finalize { $_[0]->write } +sub record_metrics { } + +sub write { + my $self = shift; + + my $list = $self->flush() or return; + my $io = $self->{+IO} or return $list; + + my $encode = $self->{+ENCODE}; + for my $item (@$list) { + my $encoded = $encode ? $encode->($item) : $item; + print $io $encoded; + } + + return $list; +} + +sub process_event { + my $self = shift; + my ($e) = @_; + + return unless $e; + return unless keys %$e; + + my $job_map = $self->{+JOB_MAP} //= {}; + my $job_id = $e->{job_id} // 0; + + my $test = $job_map->{$job_id}; + + if (my $start = $e->{facet_data}->{harness_job_start}) { + $test //= $start->{rel_file}; + + $self->start_test($test, $e) if $self->{+CAN_START_TEST}; + } + + if (my $end = $e->{facet_data}->{harness_job_end}) { + $test //= $end->{rel_file}; + + $self->stop_test($test, $e) if $self->{+CAN_STOP_TEST}; + } + + $job_map->{$job_id} //= $test if $test; + + if (my $c = $e->{facet_data}->{coverage}) { + die "Got coverage data before test start! (Weird event order?)" unless $test; + $self->_touch_coverage($test, $c, $e); + $self->record_coverage($test, $c, $e) if $self->{+CAN_RECORD_COVERAGE}; + } + + return $self->write(); +} + +sub _touch_coverage { + my $self = shift; + my ($test, $data, $e) = @_; + + if (my $new = $data->{files}) { + for my $file (keys %$new) { + my $ndata = $new->{$file} // next; + for my $sub (keys %$ndata) { + $self->{+TOUCHED}->{$file}->{$sub}++; + + next unless $self->{+CAN_TOUCH}; + $self->touch(source => $file, sub => $sub, test => $test, manager_data => $ndata->{$sub}, event => $e); + } + } + } +} + +my %PERL_TYPES = ( + pl => 1, + pm => 1, + t => 1, + tx => 1, + t2 => 1, + pmc => 1, +); + +sub build_metrics { + my $self = shift; + my %params = @_; + + my $private = $params{exclude_private}; + + my $dirs = $params{dirs} // ['lib']; + my $types = $params{types} // ['pm', 'pl']; + my $touched = $self->{+TOUCHED} //= {}; + + my $metrics = { + files => {total => 0, tested => 0}, + subs => {total => 0, tested => 0}, + untested => {files => [], subs => {}}, + }; + + my $untested = $metrics->{untested}; + + my %type_check = map { m/\.?([^\.]+)$/g; (lc($1) => 1) } @$types; + + my $raw_untested = {}; + find( + { + no_chdir => 1, + wanted => sub { + my $type = lc($_); + $type =~ s/^.*\.([^\.]+)$/$1/; + return unless $type_check{$type}; + $metrics->{files}->{total}++; + + my $file = $File::Find::name; + my $cfile = $touched->{$file}; + + if ($cfile) { + $metrics->{files}->{tested}++ + } + else { + push @{$untested->{files}} => $file; + } + + for my $sub ($PERL_TYPES{$type} ? $self->scan_subs($file) : ('<>')) { + next if $sub =~ m/^_/ && $private; + + my $special_sub = $sub !~ m/^\w/; + + $metrics->{subs}->{total}++ unless $special_sub; + + if ($cfile && $cfile->{$sub}) { + $metrics->{subs}->{tested}++ unless $special_sub; + } + else { + $raw_untested->{$file}->{$sub} = 1; + } + } + }, + }, + @$dirs + ); + + for my $file (keys %$raw_untested) { + my @val = keys %{$raw_untested->{$file}}; + next unless @val; + + if (@val == 1 && $val[0] eq '<>') { + push @{$untested->{files}} => $file; + } + else { + $untested->{subs}->{$file} = [sort @val]; + } + } + + my %seen; + @{$untested->{files}} = sort grep { !$seen{$_}++ } @{$untested->{files}}; + + $self->record_metrics($metrics); + + return $metrics; +} + +sub scan_subs { + my $self = shift; + my ($file) = @_; + + my @subs; + + my $fh; + unless (open($fh, '<', $file)) { + warn "Could not open file '$file': $!"; + return; + } + + my $in_pod = 0; + while (my $line = <$fh>) { + $in_pod = 1 if $line =~ m/^=\w/; + + if ($in_pod) { + next unless $line =~ m/^=cut/i; + $in_pod = 0; + next; + } + + last if $line =~ m/^__(END|DATA)__$/; + + next unless $line =~ m/^\s*sub\s+(\w+)/; + push @subs => $1; + } + + return @subs; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator - Module for aggregating coverage data +from a stream of events. + +=head1 DESCRIPTION + +This module takes a stream of events and produces aggregated coverage data. + +=head1 SYNOPSIS + + use Test2::Harness::Log::CoverageAggregator; + + my $agg = Test2::Harness::Log::CoverageAggregator->new(); + + while (my $e = $log->next_event) { + $agg->process_event($e); + } + + # Get a structure like { source_file => { source_method => $touched_count, ... }, ...} + my $touched_source = $agg->touched; + + # Get a structure like + # { + # files => {total => 5, tested => 2}, + # subs => {total => 20, tested => 12}, + # untested => {files => \@file_list, subs => {file => \@sub_list, ...}}, + # } + my $metrics = $agg->metrics; + + +=head1 METHODS + +=head2 IMPLEMENTABLE IN SUBLCASSES + +If you implement these in a subclass they will be called for you at the proper +times, making subclassing much easier. In most cases you can avoid overriding +process_event(). + +=over 4 + +=item $agg->start_test($test, $event) + +This is called once per test when it starts. + +B<Note:> If a test is run more than once (re-run) it will start and stop again +for each re-run. The event is also provided as an argument so that you can +check for a try-id or similar in the event that re-runs matter to you. + +=item $agg->stop_test($test, $event) + +This is called once per test when it stops. + +B<Note:> If a test is run more than once (re-run) it will start and stop again +for each re-run. The event is also provided as an argument so that you can +check for a try-id or similar in the event that re-runs matter to you. + +=item $agg->record_coverage($test, $coverage_data, $event) + +This is called once per coverage event (there can be several in a test, +specially if it forks or uses threads). + +In most cases you probably want to leave this unimplemented and implement the +C<touch()> method instead of iterating over the coverage structure yourself. + +=item $agg->touch(source => $file, sub => $sub, test => $test, manager_data => $mdata, event => $event) + +Every touch applied to a source file (and sub) will trigger this method call. + +=over 4 + +=item source => $file + +The source file that was touched + +=item sub => $sub + +The source subroutine that was touched. B<Note:> This may be '<>' if the source +file was opened via C<open()> or '*' if code outside of a subroutine was +executed by the test. + +=item test => $test + +The test file that did the touching. + +=item manager_data => $mdata + +If the test file makes use of a source manager to attach extra data to +coverage, this is where that data will be. A good example would be test suites +that use tools similar to Test::Class or Test::Class::Moose where all tests are +run in methods and you want to track what test method does the touching. Please +note that this level of coverage tracking is not automatic. + +=item event => $event + +The full event being processed. + +=back + +=back + +=head2 PUBLIC API + +=over 4 + +=item $agg->process_event($event) + +Process the event, aggregating any coverage info it may contain. + +=item $touched = $add->touched() + +Returns the following structure, which tells you how many times a specific +source file's subroutines were called. There are also "special" subroutines +'<>' and '*' which mean "file was opened via open" and "code outside of a +subroutine". + + { + source_file => { + source_method => $touched_count, + ... + }, + ... + } + +=item $metrics = $agg->build_metrics() + +=item $metrics = $agg->build_metrics(exclude_private => $BOOL) + +Will build metrics, and include them in the output from C<< $agg->coverage() >> +next time it is called. + +The C<exclude_private> option, when set to true, will exclude any method that +beings with an underscore from the coverage metrics and untested sub list. + +Metrics: + + { + files => {total => 20, tested => 18}, + subs => {total => 80, tested => 70}, + + untested => { + files => \@file_list, + subs => { + file => \@sub_list, + ... + } + }, + } + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Log/CoverageAggregator/ByRun.pm b/libold2/Test2/Harness/Log/CoverageAggregator/ByRun.pm new file mode 100644 index 000000000..1b8f0407a --- /dev/null +++ b/libold2/Test2/Harness/Log/CoverageAggregator/ByRun.pm @@ -0,0 +1,220 @@ +package Test2::Harness::Log::CoverageAggregator::ByRun; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use parent 'Test2::Harness::Log::CoverageAggregator'; +use Test2::Harness::Util::HashBase qw/<coverage <finalized/; + +sub init_coverage { + my $self = shift; + return $self->{+COVERAGE} //= {aggregator => blessed($self)}; +} + +sub record_coverage { + my $self = shift; + my ($test, $data) = @_; + + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + my $files = $coverage->{files} //= {}; + my $alltestmeta = $coverage->{testmeta} //= {}; + my $testmeta = $alltestmeta->{$test} //= {type => 'flat'}; + + if (my $type = $data->{test_type}) { + $testmeta->{type} = $type; + } + + if (my $manager = $data->{from_manager}) { + $testmeta->{manager} = $manager; + } +} + +sub touch { + my $self = shift; + my %params = @_; + + my $file = $params{source}; + my $sub = $params{sub}; + my $test = $params{test}; + my $mdata = $params{manager_data}; + + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + my $files = $coverage->{files} //= {}; + + my $set = $files->{$file}->{$sub}->{$test} //= []; + + return unless $mdata; + my $type = ref $mdata; + + if ($type eq 'ARRAY') { + my %seen; + @$set = grep { !$seen{$_}++ } @$set, @$mdata; + } + else { + push @$set => $mdata; + } +} + +sub record_metrics { + my $self = shift; + my ($metrics) = @_; + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + $coverage->{untested} = $metrics->{untested}; + $coverage->{metrics} = {files => $metrics->{files}, subs => $metrics->{subs}}; +} + +sub flush { + my $self = shift; + return unless $self->{+FINALIZED}; + return [ $self->{+COVERAGE} // $self->init_coverage ]; +} + +sub finalize { + my $self = shift; + $self->{+FINALIZED} = 1; + $self->SUPER::finalize(); +} + +sub get_coverage_tests { + my $class = shift; + my ($settings, $changes, $coverage_data) = @_; + + my $filemap = $coverage_data->{files} // {}; + my $testmeta = $coverage_data->{testmeta} // {}; + + my ($changes_exclude_loads, $changes_exclude_opens); + if ($settings->check_prefix('finder')) { + my $finder = $settings->finder; + $changes_exclude_loads = $finder->changes_exclude_loads; + $changes_exclude_opens = $finder->changes_exclude_opens; + } + + my %tests; + for my $file (keys %$changes) { + my $parts_map = $changes->{$file}; + my $parts_list = [keys %$parts_map]; + + my $use_parts; + if (!@$parts_list || $parts_map->{'*'}) { + $use_parts = [keys %{$filemap->{$file}}]; + } + else { + $use_parts = $parts_list; + } + + my %seen; + for my $part (@$use_parts) { + next if $seen{$part}++; + my $ctests = $filemap->{$file}->{$part} or next; + for my $test (keys %$ctests) { + push @{$tests{$test}->{subs}} => @{$ctests->{$test}}; + } + } + + unless ($changes_exclude_opens) { + if (my $ltests = $filemap->{$file}->{'*'}) { + for my $test (keys %$ltests) { + push @{$tests{$test}->{loads}} => @{$ltests->{$test}}; + } + } + } + + unless ($changes_exclude_loads) { + if (my $otests = $filemap->{$file}->{'<>'}) { + for my $test (keys %$otests) { + push @{$tests{$test}->{opens}} => @{$otests->{$test}}; + } + } + } + } + + my @out; + for my $test (sort keys %tests) { + my $meta = $testmeta->{$test} // {type => 'flat'}; + my $type = $meta->{type}; + my $manager = $meta->{manager}; + + # In these cases we have no choice but to run the entire file + if ($type eq 'flat' || !$manager) { + push @out => $test; + next; + } + + die "Invalid test type: $type" unless $type eq 'split'; + + my $froms = $tests{$test} // []; + my $ok = eval { + require(mod2file($manager)); + my $specs = $manager->test_parameters($test, $froms, $changes, $coverage_data, $settings); + + $specs = { run => $specs } unless ref $specs; + + push @out => [$test, $specs] + unless defined $specs->{run} && !$specs->{run}; # Intentional skip + + 1; + }; + my $err = $@; + + next if $ok; + + warn "Error processing coverage data for '$test' using manager '$manager'. Running entire test to be safe.\nError:\n====\n$@\n====\n"; + push @out => $test; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator::ByRun - Aggregate test data by run + +=head1 DESCRIPTION + + +=head1 SYNOPSIS + + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Log/CoverageAggregator/ByTest.pm b/libold2/Test2/Harness/Log/CoverageAggregator/ByTest.pm new file mode 100644 index 000000000..ae5b90a86 --- /dev/null +++ b/libold2/Test2/Harness/Log/CoverageAggregator/ByTest.pm @@ -0,0 +1,218 @@ +package Test2::Harness::Log::CoverageAggregator::ByTest; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use parent 'Test2::Harness::Log::CoverageAggregator'; +use Test2::Harness::Util::HashBase qw/<in_progress <completed/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + $self->{+IN_PROGRESS} //= {}; + $self->{+COMPLETED} //= []; +} + +sub start_test { + my $self = shift; + my ($test) = @_; + + $self->{+IN_PROGRESS}->{$test} //= {test => $test, files => {}, aggregator => blessed($self)}; +} + +sub stop_test { + my $self = shift; + my ($test) = @_; + + push @{$self->{+COMPLETED}} => delete $self->{+IN_PROGRESS}->{$test}; +} + +sub record_coverage { + my $self = shift; + my ($test, $data) = @_; + + if (my $manager = $data->{from_manager}) { + $self->{+IN_PROGRESS}->{$test}->{manager} = $manager; + } +} + +sub touch { + my $self = shift; + my %params = @_; + + my $file = $params{source}; + my $sub = $params{sub}; + my $test = $params{test}; + my $mdata = $params{manager_data}; + + my $set = $self->{+IN_PROGRESS}->{$test}->{files}->{$file}->{$sub} //= []; + + return unless $mdata; + my $type = ref $mdata; + + if ($type eq 'ARRAY') { + if (@$set) { + my %seen; + @$set = grep { !$seen{$_}++ } @$set, @$mdata; + } + else { + push @$set => @$mdata; + } + } + else { + push @$set => $mdata; + } +} + +sub flush { + my $self = shift; + + my $data = $self->{+COMPLETED} //= []; + + return unless @$data; + + $self->{+COMPLETED} = []; + + return $data; +} + +sub finalize { + my $self = shift; + + my $ip = $self->{+IN_PROGRESS}; + my $cm = $self->{+COMPLETED} //= []; + + push @{$cm} => {$_ => delete $ip->{$_}} for keys %$ip; + + $self->SUPER::finalize(); +} + +sub get_coverage_tests { + my $class = shift; + my ($settings, $changes, $coverage_data) = @_; + + my $test = $coverage_data->{test} // return; + my $filemap = $coverage_data->{files} // {}; + my $manager = $coverage_data->{manager} // undef; + + my ($changes_exclude_loads, $changes_exclude_opens); + if ($settings->check_prefix('finder')) { + my $finder = $settings->finder; + $changes_exclude_loads = $finder->changes_exclude_loads; + $changes_exclude_opens = $finder->changes_exclude_opens; + } + + my %froms; + for my $file (keys %$changes) { + my $parts_map = $changes->{$file}; + my $parts_list = [keys %$parts_map]; + + my $use_parts; + if (!@$parts_list || $parts_map->{'*'}) { + $use_parts = [keys %{$filemap->{$file}}]; + } + else { + $use_parts = $parts_list; + } + + my %seen; + for my $part (@$use_parts) { + next if $seen{$part}++; + my $cfroms = $filemap->{$file}->{$part} or next; + push @{$froms{subs}} => @{$cfroms}; + } + + unless ($changes_exclude_loads) { + if (my $lfroms = $filemap->{$file}->{'*'}) { + push @{$froms{loads}} => @{$lfroms}; + } + } + + unless ($changes_exclude_opens) { + if (my $ofroms = $filemap->{$file}->{'<>'}) { + push @{$froms{opens}} => @{$ofroms}; + } + } + } + + # Nothing to do for this test + return unless keys %froms; + + # In these cases we have no choice but to run the entire file + return ($test) unless $manager; + + my @out; + my $ok = eval { + require(mod2file($manager)); + my $specs = $manager->test_parameters($test, \%froms, $changes, $coverage_data, $settings); + + $specs = { run => $specs } unless ref $specs; + + push @out => [$test, $specs] + unless defined $specs->{run} && !$specs->{run}; # Intentional skip + + 1; + }; + my $err = $@; + + return @out if $ok; + + warn "Error processing coverage data for '$test' using manager '$manager'. Running entire test to be safe.\nError:\n====\n$@\n====\n"; + return ($test); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator::ByTest - Aggregate coverage by test + +=head1 DESCRIPTION + + +=head1 SYNOPSIS + + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Log/TimeTracker.pm b/libold2/Test2/Harness/Log/TimeTracker.pm new file mode 100644 index 000000000..c38004673 --- /dev/null +++ b/libold2/Test2/Harness/Log/TimeTracker.pm @@ -0,0 +1,370 @@ +package Test2::Harness::Log::TimeTracker; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/hub_truth/; +use Test2::Util::Times qw/render_duration/; + +use Test2::Harness::Util::HashBase qw{ + -start -start_id + -stop -stop_id + -first -first_id + -last -last_id + -complete_id + + -_source + -_totals +}; + +sub process { + my $self = shift; + my ($event, $f, $assertion_count) = @_; + + # Invalidate cache + delete $self->{+_TOTALS}; + delete $self->{+_SOURCE}; + + my $stamp = $event->{stamp} or return; + my $id = $event->{event_id} // 'N/A'; + + $f //= $event->{facet_data}; + + if ($f->{harness_job_exit}) { + $self->{+STOP} = $stamp; + $self->{+STOP_ID} = $id; + } + + return if $self->{+COMPLETE_ID}; + + if ($f->{harness_job_start}) { + $self->{+START} = $stamp; + $self->{+START_ID} = $id; + } + + # These events absolutely end the events phase, and do not count as part of + # it. + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{harness_job_exit}; + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{control} && $f->{control}->{phase} && $f->{control}->{phase} eq 'END'; + + return if $self->{+COMPLETE_ID}; + + # Plan still counts as 'event' phase, so do not return if we are setting this now + $self->{+COMPLETE_ID} //= $event->{event_id} if $assertion_count && $f->{plan} && !$f->{plan}->{none}; + + return unless $f->{trace}; # Events with traces are "event" phase. + + # Always replace the last, if we got this far. + $self->{+LAST} = $stamp; + $self->{+LAST_ID} = $id; + + # Only set the first one once + return if $self->{+FIRST}; + $self->{+FIRST} = $stamp; + $self->{+FIRST_ID} = $id; + + return; +} + +sub useful { + my $self = shift; + + my @got = grep { defined $self->{$_} } START, FIRST, LAST, STOP; + return @got > 1; +} + +my @TOTAL_FIELDS = qw/startup events cleanup total/; +my %TOTAL_SOURCES = ( + startup => [FIRST, START], + events => [LAST, FIRST], + cleanup => [STOP, LAST], + total => [STOP, START] +); +my %TOTAL_DESC = ( + startup => "Time from launch to first test event.", + events => "Time spent generating test events.", + cleanup => "Time from last test event to test exit.", + total => "Total time", +); + +sub totals { + my $self = shift; + + return $self->{+_TOTALS} if $self->{+_TOTALS}; + + my $out = {}; + + for my $field (@TOTAL_FIELDS) { + my $sources = $TOTAL_SOURCES{$field} or die "Invalid field: $field"; + my @vals = @{$self}{@$sources}; + next unless defined($vals[0]) && defined($vals[1]); + + my $delta = $vals[0] - $vals[1]; + $out->{$field} = $delta; + $out->{"h_$field"} = render_duration($delta); + } + + return $self->{+_TOTALS} = $out; +} + +sub source { + my $self = shift; + + return $self->{+_SOURCE} if $self->{+_SOURCE}; + + my @fields = ( + START, START_ID, + STOP, STOP_ID, + FIRST, FIRST_ID, + LAST, LAST_ID, + COMPLETE_ID, + ); + + my %out; + @out{@fields} = @{$self}{@fields}; + + return $self->{+_SOURCE} = \%out; +} + +sub data_dump { + my $self = shift; + + return { + totals => $self->totals, + source => $self->source, + }; +} + +sub summary { + my $self = shift; + my $totals = $self->totals; + + my $summary = ""; + for my $field (@TOTAL_FIELDS) { + my $hval = $totals->{"h_$field"} // next; + my $title = ucfirst($field); + + $summary .= " | " if $summary; + $summary .= "$title: $hval"; + } + + return $summary; +} + +sub table { + my $self = shift; + my $totals = $self->totals; + + my $table = { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [], + }; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + my $title = ucfirst($field); + + push @{$table->{rows}} => [$title, $hval, $val, $TOTAL_DESC{$field}]; + } + + return $table; +} + +sub job_fields { + my $self = shift; + my $totals = $self->totals; + + my @out; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + + my $data = {}; + my $sources = $TOTAL_SOURCES{$field}; + for my $source (@$sources) { + $data->{$source} = { + stamp => $self->{$source}, + event_id => $self->{"${source}_id"}, + }; + } + + push @out => {name => "time_$field", details => $hval, raw => $val, data => $data}; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::TimeTracker - Module that tracks timing data while an +event stream is processed. + +=head1 DESCRIPTION + +The timetracker module tracks timing data of an event stream. All events for a +given job should be run through a timetracker, which can then give data on how +long the test took in each of several stages. + +=over 4 + +=item startup - Time from launch to first test event. + +=item events - Time spent generating test events. + +=item cleanup - Time from last test event to test exit. + +=item total - Total time. + +=back + +=head1 SYNOPSIS + + use Test2::Harness::Log::TimeTracker; + + my $tracker = Test2::Harness::Log::TimeTracker->new(); + + my $assert_count = 0; + for my $event (@events) { + my $facet_data = $events->facet_data; + $assert_count++ if $facet_data->{assert}; + $tracker->process($event, $facet_data, $assert_count); + } + + print $tracker->summary; + # Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +=head1 METHODS + +=over 4 + +=item $tracker->process($event, $facet_data, $assert_count) + +=item $tracker->process($event, undef, $assert_count) + +TimeTracker builds its state from multiple events, each event should be +processed by this method. + +The second argument is optional, if no facet_data is provided it will pull the +facet_data from the event itself. This is mainly a micro-optimization to avoid +calling the C<facet_data()> method on the event multiple times if you have +already called it. + +=item $bool = $tracker->useful() + +Returns true if there is any useful data to display. + +=item $totals = $tracker->totals() + +Returns the totals like this: + + { + # Raw numbers + startup => ..., + events => ..., + cleanup => ..., + total => ..., + + # Human friendly versions + h_startup => ..., + h_events => ..., + h_cleanup => ..., + h_total => ..., + } + +=item $source = $tracker->source() + +This method returns the data from which the totals are derived. + + { + start => ..., # timestamp of the job starting + stop => ..., # timestamp of the job ending + first => ..., # timestamp of the first non-harness event + last => ..., # timestamp of the last non-harness event + + # These are event_id's of the events that provided the above stamps. + start_id => ..., + stop_id => ..., + first_id => ..., + last_id => ..., + complete_id => ..., + } + +=item $data = $tracker->data_dump + +This dumps the totals and source data: + + { + totals => $tracker->totals, + source => $tracker->source, + } + +=item $string = $tracker->summary + +This produces a summary string of the totals data: + + Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +Fields that have no data will be ommited from the string. + +=item $table = $tracker->table + +Returns this structure that is good for use in L<Term::Table>. + + { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [ + ['startup', $human_readible, $raw, "Time from launch to first test event."], + ['events', $human_radible, $raw, 'Time spent generating test events.'], + ['cleanup', $human_radible, $raw, 'Time from last test event to test exit.'], + ['total', $human_radible, $raw, 'Total time.'], + ], + } + +=item @items = $tracker->job_fields() + +This is used to obtain extra data to attach to the job completion event. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Plugin.pm b/libold2/Test2/Harness/Plugin.pm new file mode 100644 index 000000000..b27cfb2b7 --- /dev/null +++ b/libold2/Test2/Harness/Plugin.pm @@ -0,0 +1,349 @@ +package Test2::Harness::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +# Document, but do not implement +#sub changed_files {} +#sub changed_diff {} + +sub munge_search {} + +sub claim_file {} + +sub munge_files {} + +sub inject_run_data {} + +sub setup {} + +sub teardown {} + +sub TO_JSON { ref($_[0]) || "$_[0]" } + +sub redirect_io { + my $this = shift; + my ($settings, $name) = @_; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "This cannot be used without a workspace $at" unless $settings->check_prefix('workspace'); + + require File::Spec; + require Test2::Harness::Util::IPC; + + my $dir = $settings->workspace->workdir; + my $aux = File::Spec->catdir($dir, 'aux_logs'); + mkdir($aux) unless -d $aux; + + Test2::Harness::Util::IPC::swap_io(\*STDOUT, File::Spec->catfile($aux, "${name}-STDOUT.log")); + Test2::Harness::Util::IPC::swap_io(\*STDERR, File::Spec->catfile($aux, "${name}-STDERR.log")); + + return; +} + +sub shellcall { + my $this = shift; + my ($settings, $name, @cmd) = @_; + + require POSIX; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "No command provided $at" unless @cmd && length($cmd[0]); + + my $pid = fork // die "Could not fork: $!"; + if ($pid) { + waitpid($pid, 0); + return $?; + } + else { + local $@; + + eval { + if ($settings->check_prefix('workspace')) { + $this->redirect_io($settings, $name); + } + exec(@cmd) if @cmd > 1; + exec($cmd[0]); + }; + + chomp(my $err = $@ // "unknown error"); + + warn "Could not run command ($@) $at"; + POSIX::_exit(1); + } +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Plugin - Base class for Test2::Harness plugins. + +=head1 DESCRIPTION + +This class holds the methods specific to L<Test2::Harness> which +is the backend. Most of the time you actually want to subclass +L<App::Yath::Plugin> which subclasses this class, and holds additional methods +that apply to yath (the UI layer). + +=head1 SYNOPSIS + +You probably want to subclass L<App::Yath::Plugin> instead. This class here +mainly exists to separate concerns, but is not something you should use +directly. + + package Test2::Harness::Plugin::MyPlugin; + + use parent 'Test2::Harness::Plugin'; + + # ... Define methods + + 1; + +=head1 METHODS + +=over 4 + +=item $plugin->munge_search($input, $default_search, $settings) + +C<$input> is an arrayref of files and/or directories provided at the command +line. + +C<$default_search> is an arrayref with the default files/directories pulled in +when nothing is specified at the command ine. + +C<$settings> is an instance of L<Test2::Harness::Settings> + +=item $undef_or_inst = $plugin->claim_file($path, $settings) + +This is a chance for a plugin to claim a test file early, before Test2::Harness +takes care of it. If your plugin does not want to claim the file just return +undef. To claim the file return an instance of L<Test2::Harness::TestFile> +created with C<$path>. + +=item $plugin->munge_files(\@tests, $settings) + +This is an opportunity for your plugin to modify the data for any test file +that will be run. The first argument is an arrayref of +L<Test2::Harness::TestFile> objects. + +=item $hashref = $plugin->duration_data($settings, $test_names) + +If defined, this can return a hashref of duration data. This should return +undef if no duration data is provided. The first plugin listed that provides +duration data wins, no other plugins will be checked once duration data is +obtained. + +Example duration data: + + { + 't/foo.t' => 'medium', + 't/bar.t' => 'short', + 't/baz.t' => 'long', + } + +=item $hashref_or_arrayref = $plugin->coverage_data(\@changed) + +=item $hashref_or_arrayref = $plugin->coverage_data() + +If defined, this can return a hashref of all coverage data, or an arrayref of +tests that cover the tests listed in @changed. This should return undef if no +coverage data is available. The first plugin to provide coverage data wins, no +other plugins will be checked once coverage data has been obtained. + +Examples: + + [ + 'foo.t', + 'bar.t', + 'baz.t', + ] + + { + 'lib/Foo.pm' => [ + 't/foo.t', + 't/integration.t', + ], + 'lib/Bar.pm' => [ + 't/bar.t', + 't/integration.t', + ], + } + +=item $plugin->post_process_coverage_tests($settings, \@tests) + +This is an opportunity for a plugin to do post-processing on the list of +coverage tests to run. This is mainly useful to remove duplicates if multiple +plugins add coverage data, or merging entries where applicable. This will be +called after all plugins have generated their coverage test list. + +Plugins may implement this without implementing coverage_data(), making this +useful if you want to use a pre-existing coverage module and want to do +post-processing on what it provides. + +=item $plugin->inject_run_data(meta => $meta, fields => $fields, run => $run) + +This is a callback that lets your plugin add meta-data or custom fields to the +run event. The meta-data and fields are available in the event log, and are +particularily useful to L<App::Yath::UI>. + + sub inject_run_data { + my $class = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + # Meta-data is a hash, each plugin should define its own key, and put + # data under that key + $meta->{MyPlugin}->{stuff} = "Stuff!"; + + # Fields is an array of fields that a UI might want to display when showing the run. + push @$fields => {name => 'MyPlugin', details => "Human Friendly Stuff", raw => "Less human friendly stuff", data => $all_the_stuff}; + + return; + } + +=item $plugin->setup($settings) + +This is a callback that lets you run setup logic when the runner starts. Note +that in a persistent runner this is run once on startup, it is not run for each +C<run> command against the persistent runner. + +=item $plugin->teardown($settings) + +This is a callback that lets you run teardown logic when the runner stops. Note +that in a persistent runner this is run once on termination, it is not run for +each C<run> command against the persistent runner. + +=item @files = $plugin->changed_files($settings) + +Get a list of files that have changed. Plugins are free to define what +"changed" means. This may be used by the finder to determine what tests to run +based on coverage data collected in previous runs. + +Note that data from all changed_files() calls from all plugins will be merged. + +=item ($type, $value) = $plugin->changed_diff($settings) + +Generate a diff that can be used to calculate changed files/subs for which to +run tests. Unlike changed_files(), only 1 diff will be used, first plugin +listed that returns one wins. This is not run at all if a diff is provided via +--changed-diff. + +Diffs must be in the same format as this git command: + + git diff -U1000000 -W --minimal BASE_BRANCH_OR_COMMIT + +Some other diff formats may work by chance, but they are not dirfectly +supported. In the future other diff formats may be directly supported, but not +yet. + +The following return sets are allowed: + +=over 4 + +=item file => string + +Path to a diff file + +=item diff => string + +In memory diff as a single string + +=item lines => \@lines + +Diff where each line is a seperate string in an arrayref. + +=item line_sub => sub { ... } + +Sub that returns one line per call and undef when there are no more lines + +=item handle => $FH + +A filehandle to the diff + +=back + +=item $exit = $plugin->shellcall($settings, $name, $cmd) + +=item $exit = $plugin->shellcall($settings, $name, @cmd) + +This is essentially the same as C<system()> except that STDERR and STDOUT are +redirected to files that the yath collector will pick up so that any output +from the command will be seen as events and will be part of the yath log. If no +workspace is available this will not redirect IO and it will be identical to +calling C<system()>. + +This is particularily useful in C<setup()> and C<teardown()> when running +external commands, specially any that daemonize and continue to produce output +after the setup/teardown method has completed. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->redirect_io($settings, $name) + +B<WARNING:> This must NEVER be called in a primary yath process. Only use this +in forked processes that you control. If this is used in a main process it +could hide ALL output. + +This will redirect STDERR and STDOUT to files that will be picked up by the +yath collector so that any output appears as proper yath events and will be +included in the yath log. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->TO_JSON + +This is here as a bare minimum serialization method. It returns the plugin +class name. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Renderer.pm b/libold2/Test2/Harness/Renderer.pm new file mode 100644 index 000000000..4442d0e7f --- /dev/null +++ b/libold2/Test2/Harness/Renderer.pm @@ -0,0 +1,154 @@ +package Test2::Harness::Renderer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw/-settings -verbose -progress -color -command_class/; + +sub render_event { croak "$_[0] forgot to override 'render_event()'" } + +sub step {} + +sub finish { } + +sub signal { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer - Base class for Test2::Harness event renderers. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be changed. + +=over 4 + +=item $settings = $renderer->settings + +Get the L<Test2::Harness::Settings> reference. + +=item $int = $renderer->verbose + +Get the verbosity level. + +=item $bool = $renderer->progress + +True if progress indicators should be shown. + +=item $bool = $renderer->color + +True if color should be used. + +=back + +=head1 METHODS + +=over 4 + +=item $renderer->render_event($event) + +Called for every event. Return is ignored. + +=item $renderer->finish(%ARGS) + +Called once after testing is done. + +C<%ARGS>: + +=item $renderer->signal($signal) + +Called when the rendering process receives a signal. This is your chance to do +any cleanup or report the signal. This is not an event, you can ignore it. Do +not exit or throw any exceptions here please. + +=over 4 + +=item settings => $settings + +Get the L<Test2::Harness::Settings> reference. + +=item pass => $bool + +True if tests passed. + +=item tests_seen => $int + +Number of test files seen. + +=item asserts_seen => $int + +Number of assertions made. + +=item final_data => $final_data + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Renderer/Formatter.pm b/libold2/Test2/Harness/Renderer/Formatter.pm new file mode 100644 index 000000000..45f04f0ff --- /dev/null +++ b/libold2/Test2/Harness/Renderer/Formatter.pm @@ -0,0 +1,215 @@ +package Test2::Harness::Renderer::Formatter; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Storable qw/dclone/; + +use Test2::Harness::Util qw/fqmod mod2file/; +use Test2::Harness::Util::JSON qw/encode_pretty_json/; + +BEGIN { require Test2::Harness::Renderer; our @ISA = ('Test2::Harness::Renderer') } +use Test2::Harness::Util::HashBase qw{ + -io -io_err + -formatter + -show_run_info + -show_job_info + -show_job_launch + -show_job_end + -do_step + -interactive +}; + +sub init { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + + my $formatter = $self->{+FORMATTER} //= 'Test2'; + my $f_class = fqmod('Test2::Formatter', $formatter); + my $f_file = mod2file($f_class); + require $f_file; + + my $io = $self->{+IO} || $self->{output} || \*STDOUT; + unless (ref $io) { + open(my $fh, '>', $io) or die "Could not open file '$io' for writing: $!"; + $self->{+IO} = $fh; + } + + my $io_err = $self->{+IO_ERR} || $self->{output} || \*STDERR; + unless (ref $io_err) { + open(my $fh, '>', $io_err) or die "Could not open file '$io_err' for writing: $!"; + $self->{+IO_ERR} = $fh; + } + + $self->{+INTERACTIVE} = 1 if $settings->debug->interactive; + $self->{+INTERACTIVE} //= 1 if $ENV{YATH_INTERACTIVE}; + + $self->{+FORMATTER} = $f_class->new( + io => $self->{+IO}, + progress => $self->{+PROGRESS}, + handles => [$self->{+IO}, $self->{+IO_ERR}, $self->{+IO}], + verbose => $settings->display->verbose, + color => $settings->display->color, + no_wrap => $settings->display->no_wrap, + interactive => $self->{+INTERACTIVE}, + is_persistent => $self->{+COMMAND_CLASS}->group eq 'persist' ? 1 : 0, + ); + + $self->{+DO_STEP} = $self->{+FORMATTER}->can('step') ? 1 : 0; + + $self->{+SHOW_JOB_END} = 1 unless defined $self->{+SHOW_JOB_END}; +} + +sub step { + my $self = shift; + return unless $self->{+DO_STEP}; + $self->{+FORMATTER}->step; +} + +sub render_event { + my $self = shift; + my ($event) = @_; + + # We modify the event, which would be bad if there were multiple renderers, + # so we deep clone it. + $event = dclone($event); + + my $settings = $self->{+SETTINGS}; + + my $f = $event->{facet_data}; # Optimization + + $f->{harness} = {%$event}; + delete $f->{harness}->{facet_data}; + + if ($self->{+SHOW_RUN_INFO} && $f->{harness_run}) { + my $run = $f->{harness_run}; + + push @{$f->{info}} => { + tag => 'RUN INFO', + details => encode_pretty_json($run), + }; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + + $f->{harness}->{job_id} ||= $job->{job_id}; + + if ($self->{+SHOW_JOB_LAUNCH}) { + push @{$f->{info}} => { + tag => $f->{harness_job_launch}->{retry} ? 'RETRY' : 'LAUNCH', + debug => 0, + important => 1, + details => File::Spec->abs2rel($job->{file}), + }; + } + + if ($self->{+SHOW_JOB_INFO}) { + push @{$f->{info}} => { + tag => 'JOB INFO', + details => encode_pretty_json($job), + }; + } + } + + if ($f->{harness_job_end}) { + my $job = $f->{harness_job}; + my $skip = $f->{harness_job_end}->{skip}; + my $fail = $f->{harness_job_end}->{fail}; + my $file = $f->{harness_job_end}->{file}; + my $retry = $f->{harness_job_end}->{retry}; + + my $job_id = $f->{harness}->{job_id} ||= $job->{job_id}; + + # Make the times important if they were requested + if ($settings->display->show_times && $f->{info}) { + for my $info (@{$f->{info}}) { + next unless $info->{tag} eq 'TIME'; + $info->{important} = 1; + } + } + + if ($self->{+SHOW_JOB_END}) { + my $name = File::Spec->abs2rel($file); + $name .= " - $skip" if $skip; + + my $tag = 'PASSED'; + $tag = 'SKIPPED' if $skip; + $tag = 'FAILED' if $fail; + $tag = 'TO RETRY' if $retry; + + unshift @{$f->{info}} => { + tag => $tag, + debug => $fail, + important => 1, + details => $name, + }; + } + } + + my $num = $f->{assert} && $f->{assert}->{number} ? $f->{assert}->{number} : undef; + + $self->{+FORMATTER}->write($event, $num, $f); +} + +sub finish { + my $self = shift; + $self->{+FORMATTER}->finalize(); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer::Formatter - Renderer that uses any Test2::Formatter +for rendering. + +=head1 DESCRIPTION + +This renderer simply acts as a communication layer between the harness and any +Test2 formatter that you wish to use to display results. Not all formatters +will produce useful output for harness events. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Run.pm b/libold2/Test2/Harness/Run.pm new file mode 100644 index 000000000..06b13075d --- /dev/null +++ b/libold2/Test2/Harness/Run.pm @@ -0,0 +1,182 @@ +package Test2::Harness::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <run_id + + <env_vars <author_testing <unsafe_inc + + <links + + <event_uuids + <use_stream + <mem_usage + <io_events + + <dbi_profiling + + <input <input_file <test_args + + <load <load_import + + <fields <meta + + <retry <retry_isolated +}; + +sub init { + my $self = shift; + + croak "run_id is required" + unless $self->{+RUN_ID}; +} + +sub run_dir { + my $self = shift; + my ($workdir) = @_; + return File::Spec->catfile($workdir, $self->{+RUN_ID}); +} + +sub TO_JSON { +{ %{$_[0]} } } + +sub queue_item { + my $self = shift; + my ($plugins) = @_; + + croak "a plugins arrayref is required" unless $plugins; + + my $out = {%$self}; + + my $meta = $out->{+META} //= {}; + my $fields = $out->{+FIELDS} //= []; + for my $p (@$plugins) { + $p->inject_run_data(meta => $meta, fields => $fields, run => $self); + } + + return $out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Run - Representation of a set of tests to run, and their +options. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be modified. + +See L<App::Yath::Options::Run> for more documentation on these. + +=head2 FROM OPTIONS + +=over 4 + +=item $bool = $run->author_testing + +=item $hashref = $run->env_vars + +=item $bool = $run->event_uuids + +=item $arrayref = $run->fields + +=item $string = $run->input + +=item $path = $run->input_file + +=item $bool = $run->io_events + +=item $arrayref = $run->links + +=item $arrayref = $run->load + +=item $hashref = $run->load_import + +=item $bool = $run->mem_usage + +=item $int = $run->retry + +=item $bool = $run->retry_isolated + +=item $string = $run->run_id + +=item $arrayref = $run->test_args + +=item $bool = $run->unsafe_inc + +=item $bool = $run->use_stream + +=back + +=head2 OTHER + +=over 4 + +=item $hashref = $run->meta + +meta-data plugins may have attached. + +=back + +=head1 METHODS + +=over 4 + +=item $path = $run->run_dir($workdir) + +Returns the path C<"$workdir/$run_id">. + +=item $hashref = $run->queue_item(\@PLUGINS) + +Gets the queue item that represents this object. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner.pm b/libold2/Test2/Harness/Runner.pm new file mode 100644 index 000000000..048837c6e --- /dev/null +++ b/libold2/Test2/Harness/Runner.pm @@ -0,0 +1,692 @@ +package Test2::Harness::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use POSIX qw/:sys_wait_h/; +use Long::Jump qw/setjump longjump/; +use Time::HiRes qw/sleep time/; +use Scope::Guard; + +use Test2::Harness::Util qw/clean_path file2mod mod2file open_file parse_exit write_file_atomic process_includes chmod_tmp write_file/; +use Test2::Harness::Util::JSON(qw/encode_json/); + +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run(); +use Test2::Harness::Runner::Job(); +use Test2::Harness::Runner::Spawn(); +use Test2::Harness::Runner::State(); +use Test2::Harness::Runner::Preload(); +use Test2::Harness::Runner::Preloader(); +use Test2::Harness::Runner::Preloader::Stage(); +use Test2::Harness::Runner::DepTracer(); + +use parent 'Test2::Harness::IPC'; +use Test2::Harness::Util::HashBase( + # Fields from settings + qw{ + <job_count <slots_per_job + + <includes <tlib <lib <blib + <unsafe_inc + + <use_fork <preloads <preload_threshold <switches + <restrict_reload + + <cover + + <event_timeout <post_exit_timeout + + <resources + + <nytprof + + <reload + }, + # From Construction + qw{ + <dir <settings <fork_job_callback <fork_spawn_callback <respawn_runner_callback <monitor_preloads + <jobs_todo <dump_depmap <all_state + }, + # Other + qw { + +preloader + +state + + <stage + <signal + + +last_timeout_check + +dispatch_lock_file + +can_stage + <tmp_dir + + <rootpid + }, +); + +sub job_class { 'Test2::Harness::Runner::Job' } + +our $RUNNER_PID; +sub init { + my $self = shift; + + $self->{+ROOTPID} = $$; + $RUNNER_PID = $$; + + croak "'dir' is a required attribute" unless $self->{+DIR}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + my $dir = clean_path($self->{+DIR}); + + croak "'$dir' is not a valid directory" + unless -d $dir; + + $self->{+DIR} = $dir; + + $self->{+HANDLERS}->{HUP} = sub { + my $sig = shift; + print "$$ $0 ($self->{+STAGE}) Runner caught SIG$sig, reloading...\n"; + $self->{+SIGNAL} = $sig; + }; + + my $tmp_dir = File::Spec->catdir($self->{+DIR}, 'tmp'); + unless (-d $tmp_dir) { + mkdir($tmp_dir) or die "Could not create temp dir: $!"; + chmod_tmp($tmp_dir); + } + $self->{+TMP_DIR} = $tmp_dir; + + my $have_job_limiter = 0; + for my $res (@{$self->{+RESOURCES}}) { + require(mod2file($res)) unless ref($res); + $have_job_limiter++ if $res->job_limiter; + } + + unless ($have_job_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$self->{+RESOURCES}} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + $self->SUPER::init(); +} + +sub preloader { + my $self = shift; + + $self->{+PRELOADER} //= Test2::Harness::Runner::Preloader->new( + dir => $self->{+DIR}, + preloads => $self->preloads, + monitor => $self->{+MONITOR_PRELOADS}, + restrict_reload => $self->{+RESTRICT_RELOAD}, + dump_depmap => $self->{+DUMP_DEPMAP}, + reload => $self->{+RELOAD}, + + below_threshold => ($self->{+PRELOAD_THRESHOLD} && $self->{+JOBS_TODO} && $self->{+PRELOAD_THRESHOLD} > $self->{+JOBS_TODO}) ? 1 : 0, + ); +} + +sub state { + my $self = shift; + + my $preloader = $self->preloader; + + my $settings = $self->settings; + $self->{+STATE} //= Test2::Harness::Runner::State->new( + workdir => $self->{+DIR}, + eager_stages => $preloader->eager_stages // {}, + preloader => $preloader, + resources => [map { $_->new(settings => $settings) } @{$self->{+RESOURCES}}], + settings => $settings, + ); +} + +sub check_timeouts { + my $self = shift; + + return unless $self->settings->runner->use_timeout; + + my $now = time; + + # Check only once per second, that is as granular as we get. Also the check is not cheep. + return if $self->{+LAST_TIMEOUT_CHECK} && $now < (1 + $self->{+LAST_TIMEOUT_CHECK}); + + for my $pid (keys %{$self->{+PROCS}}) { + my $job = $self->{+PROCS}->{$pid}; + next unless $job->isa('Test2::Harness::Runner::Job'); + next unless $job->use_timeout; + + my $et = $job->event_timeout // $self->{+EVENT_TIMEOUT}; + my $pet = $job->post_exit_timeout // $self->{+POST_EXIT_TIMEOUT}; + + next unless $et || $pet; + + my $changed = $job->output_changed(); + my $delta = $now - $changed; + + # Event timout if we are checking for one, and if the delta is larger than the timeout. + my $e_to = $et && $delta > $et; + + # Post-Exit timeout if we are checking for one, the process has exited (we are waiting) and the delta is larger than the timeout. + my $pe_to = $pet && $self->{+WAITING}->{$pid} && $delta > $pet; + + next unless $e_to || $pe_to; + + my $kill = -f $job->et_file || -f $job->pet_file; + + write_file_atomic($job->et_file, "$now $delta") if $e_to && !-f $job->et_file; + write_file_atomic($job->pet_file, "$now $delta") if $pe_to && !-f $job->pet_file; + + my $sigmap = $self->SIG_MAP; + my $sig = $kill ? $sigmap->{'KILL'} : $sigmap->{'TERM'}; + + $sig = "-$sig" if $self->USE_P_GROUPS; + + print STDERR "$$ $0 " . $job->file . " did not respond to SIGTERM, sending SIGKILL to $pid...\n" if $kill; + + # storing the jobid we had to stop + $self->{run_reached_timeout} //= {}; + $self->{run_reached_timeout}->{$job->task->{job_id}} = $pid; + + kill($sig, $pid); + } + + $self->{+LAST_TIMEOUT_CHECK} = time; +} + +sub stop { + my $self = shift; + + $self->check_for_fork; + + if (keys %{$self->{+PROCS}}) { + print "$$ $0 Sending all child processes the TERM signal...\n"; + # Send out the TERM signal + $self->killall($self->{+SIGNAL} // 'TERM'); + $self->wait(all => 1, timeout => 5); + } + + # Time to get serious + if (keys %{$self->{+PROCS}}) { + print STDERR "$$ $0 Some child processes are refusing to exit, sending KILL signal...\n"; + print("$$ $0 == $_ " . waitpid($_, WNOHANG) . "\n") for keys %{$self->{+PROCS}}; + $self->killall('KILL'); + } + + $self->SUPER::stop(); +} + +sub dispatch_lock_file { + my $self = shift; + return $self->{+DISPATCH_LOCK_FILE} //= File::Spec->catfile($self->{+DIR}, 'dispatch.lock'); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + return if $self->{+SIGNAL}; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->{+SIGNAL} = $sig; + die "Runner caught SIG$sig. Attempting to shut down cleanly...\n"; +} + +sub all_libs { + my $self = shift; + + my @out; + + push @out => @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + push @out => 't/lib' if $self->{+TLIB}; + push @out => 'lib' if $self->{+LIB}; + + if ($self->{+BLIB}) { + push @out => 'blib/lib'; + push @out => 'blib/arch'; + } + + return @out; +} + +sub process { + my $self = shift; + + @INC = process_includes( + list => [@{$self->settings->harness->dev_libs}, $self->all_libs], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + ); + + my $pidfile = File::Spec->catfile($self->{+DIR}, 'PID'); + write_file_atomic($pidfile, "$$"); + + $self->start(); + + my $ok = eval { $self->run_tests(); 1 }; + my $err = $@; + $self->{+CAN_STAGE} = 0; + + warn $err unless $ok; + + $self->stop(); + + return $self->{+SIGNAL} ? 128 + $self->SIG_MAP->{$self->{+SIGNAL}} : $ok ? 0 : 1; +} + +sub spawn_scheduler { + my $self = shift; + + return unless $self->{+ROOTPID} == $$; + + my $pid = fork // die "Could not fork: $!"; + return $self->watch_pid($pid) if $pid; + + my $guard = Scope::Guard->new(sub { + print STDERR "\n\nEscaped Scope!!!!\n\n"; + print STDERR $@; + exit 255; + }); + + $0 =~ s/-runner/-scheduler/i; + + my $state = $self->state; + + my $lock = open_file($self->dispatch_lock_file, '>>'); + + while (1) { + $state->poll; + + flock($lock, LOCK_EX) or die "Could not get scheduler lock: $!"; + + while (1) { + next if $state->advance; + last; + } + + flock($lock, LOCK_UN) or die "Could not release scheduler lock: $!"; + + if ($self->end_test_loop()) { + $guard->dismiss; + exit(0); + } + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "Escaped scheduler loop"; + exit 255; +} + +sub run_tests { + my $self = shift; + + my $preloader = $self->preloader; + $preloader->preload(); + + $self->spawn_scheduler(); + + my ($stage, @procs) = $preloader->preload_stages(); + + if ($self->dump_depmap) { + if (my $dtrace = $preloader->dtrace) { + if (my $depmap = $dtrace->dep_map) { + my $file = "depmap-$stage.json"; + write_file($file, encode_json($depmap)); + } + } + } + + $self->watch($_) for @procs; + + while(1) { + $self->{+CAN_STAGE} = 1; + my $jump = setjump "Stage-Runner" => sub { + $self->run_stage($stage); + }; + + last unless $jump; + + ($stage) = @$jump; + $self->reset_stage(); + } + + return; +} + +sub reset_stage { + my $self = shift; + + # Normalize IPC + $self->check_for_fork(); + + # If no stage was set we do not want to clear this, root stages need to + # preserve the preloads + return unless $self->{+STAGE}; + + # From Runner + delete $self->{+STAGE}; + delete $self->{+STATE}; + delete $self->{+LAST_TIMEOUT_CHECK}; + + return; +} + +sub run_stage { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE} = $stage; + $self->state->stage_ready($stage); + + while (1) { + next if $self->run_job(); + + next if $self->wait(); + + last if $self->end_test_loop(); + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + $self->state->stage_down($stage); + + $self->killall($self->{+SIGNAL}) if $self->{+SIGNAL}; + + $self->wait(all => 1); + + exit 0 unless $stage eq 'base' || $stage eq 'default'; +} + +sub run_job { + my $self = shift; + + my $task = $self->state->next_task($self->{+STAGE}) or return 0; + + if ($task->{spawn} && !$task->{resource_skip}) { + my $job = Test2::Harness::Runner::Spawn->new( + runner => $self, + task => $task, + settings => $self->settings, + fork_callback => $self->{+FORK_SPAWN_CALLBACK}, + ); + + $self->{+FORK_SPAWN_CALLBACK}->($self, $job); + return 1; + } + + my $run = $self->state->run(); + return 1 unless $run; + + my $job_class; + if ($task->{job_class}) { + $job_class = $task->{job_class}; + require(mod2file($job_class)); + + die "Custom job class $job_class overrode the category, this is a fatal mistake" + unless $job_class->category eq $self->job_class->category; + } + else { + $job_class = $self->job_class; + } + + my $job = $job_class->new( + runner => $self, + task => $task, + run => $run, + settings => $self->settings, + fork_callback => $self->{+FORK_JOB_CALLBACK}, + ); + + $job->prepare_dir(); + + my $spawn_time; + + my $pid; + my $via = $job->via(); + if ($via) { + require(mod2file($1)) if !defined(&{$via}) && $via =~ m/^(.+)::[^:]+$/; + + $spawn_time = time(); + $pid = $self->$via($job); + $job->set_pid($pid); + $self->watch($job); + } + else { + $spawn_time = time(); + $self->spawn($job); + $pid = $job->pid; + } + + $run->add_job($job, $spawn_time); + + return $pid; +} + +sub end_test_loop { + my $self = shift; + + my $state = $self->state; + + no warnings 'uninitialized'; + if (!$self->{+STAGE} || $self->{+STAGE} eq 'default' || $self->{+STAGE} eq 'base') { + $self->{+RESPAWN_RUNNER_CALLBACK}->() + if $self->preloader->check($state) || ($self->{+SIGNAL} && $self->{+SIGNAL} eq 'HUP'); + } + + if ($self->preloader->check($state)) { + $self->{+SIGNAL} //= 'HUP'; + return 1; + } + + return 1 if $self->{+SIGNAL}; + + return 1 if $state->done; + + return 0; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, $exit, $time, @args) = @_; + + if ($proc->isa('Test2::Harness::Runner::Job')) { + my $task = $proc->task; + + my $timed_out = 0; + if ( !$exit && ref $self->{run_reached_timeout} && $self->{run_reached_timeout}->{ $task->{job_id} } ) { + delete $self->{run_reached_timeout}->{ $task->{job_id} }; + $timed_out = 1; + } + + if (($exit || $timed_out) && $proc->is_try < $proc->retry ) { + $self->state->retry_task($task->{job_id}); + push @args => 'will-retry'; + } + else { + $self->state->stop_task($task->{job_id}); + } + + if(my $bail = $exit ? $proc->bailed_out : 0) { + print "$$ $0 BAIL-OUT detected: $bail\n"; + if ($self->settings->runner->abort_on_bail) { + print "$$ $0 Aborting the test run...\n"; + $self->state->halt_run($task->{run_id}); + } + } + } + elsif ($proc->isa('Test2::Harness::Runner::Preloader::Stage')) { + my $stage = $proc->name; + + if ($exit != 0) { + my $e = parse_exit($exit); + my $err = "$$ $0 Child stage '$stage' did not exit cleanly (sig: $e->{sig}, err: $e->{err})!\n"; + $self->{+MONITOR_PRELOADS} ? warn $err : die $err; + } + + if ($self->{+MONITOR_PRELOADS} && $self->{+CAN_STAGE} && !$self->end_test_loop) { + my $pid = $$; + my ($name, @procs) = $self->preloader->_preload_stages($stage); + $self->watch($_) for @procs; + longjump "Stage-Runner" => $name unless $pid == $$; + } + } + + $self->SUPER::set_proc_exit($proc, $exit, $time, @args); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner - Base class for test runners + +=head1 DESCRIPTION + +This module does the heavy lifting of running all the tests. + +You should never need to create an instance of the runner yourself. In most +cases the runner module is exposed via a callback or a plugin affordance. + +=head1 PUBLIC METHODS + +=head2 FROM SETTINGS + +These are attributesd with values set from the L<Test2::Harness::Settings> +instance created from command line arguments. + +See L<App::Yath::Options::Runner> for the most up to date documentation on +these. + +=over 4 + +=item $runner->includes + +=item $runner->tlib + +=item $runner->lib + +=item $runner->blib + +=item $runner->unsafe_inc + +=item $runner->use_fork + +=item $runner->preloads + +=item $runner->preload_threshold + +=item $runner->switches + +=item $runner->cover + +=item $runner->event_timeout + +=item $runner->post_exit_timeout + +=back + +=head2 FROM CONSTRUCTION + +These attributes are set when the runner is created. + +=over 4 + +=item $path = $runner->dir + +Path to the working directory. + +=item $settings = $runner->settings + +The L<App::Yath::Settings> instance. + +=item $coderef = $runner->fork_job_callback + +Callback used to spawn new tests via fork. + +=item $coderef = $runner->respawn_runner_callback + +Callback to restart the runner process. + +=item $bool = $runner->monitor_preloads + +True if preloads should be watched for changes. + +=item $int = $runner->jobs_todo + +A count of total jobs to run. This will always be 0 in a persistent runner. + +=back + +=head2 OTHER PUBLIC METHODS + +If a method is not documented here then it is an implementation detail and you +should not use it. + +=over 4 + +=item $class = $runner->job_class + +Class for new test jobs. + +=item $preload = $runner->preloader + +Get the L<Test2::Harness::Runner::Preloader> instance. + +=item $state = $runner->state + +Get the L<Test2::Harness::Runner::State> instance. + +=item @list = $runner->all_libs + +Get all the libs that should be added to @INC by default. Note that specific +runs and even specific tests can have custom paths on top of these. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Constants.pm b/libold2/Test2/Harness/Runner/Constants.pm new file mode 100644 index 000000000..ce20a0380 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Constants.pm @@ -0,0 +1,72 @@ +package Test2::Harness::Runner::Constants; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT = qw/CATEGORIES DURATIONS/; + +use constant CATEGORIES => {general => 1, isolation => 1, immiscible => 1}; +use constant DURATIONS => {long => 1, medium => 1, short => 1}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Constants - Constants shared between multiple runner +modules. + +=head1 DESCRIPTION + +Export some common structures. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::Constants qw/CATEGORIES DURATIONS/; + + if (CATEGORIES->{$cat}) { + print "$cat is valid\n"; + } + else { + print "$cat is not valid\n"; + } + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/DepTracer.pm b/libold2/Test2/Harness/Runner/DepTracer.pm new file mode 100644 index 000000000..301ad0855 --- /dev/null +++ b/libold2/Test2/Harness/Runner/DepTracer.pm @@ -0,0 +1,283 @@ +package Test2::Harness::Runner::DepTracer; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw/ + -_on + -exclude + -dep_map + -loaded + -my_require + -real_require + -_my_inc + -callbacks +/; + +my %DEFAULT_EXCLUDE = ( + 'warnings.pm' => 1, + 'strict.pm' => 1, +); + +my $ACTIVE; + +sub ACTIVE { $ACTIVE } + +sub start { + my $self = shift; + + croak "There is already an active DepTracer" if $ACTIVE; + + $ACTIVE = $self; + + unshift @INC => $self->my_inc; + + $self->{+_ON} = 1; +} + +sub stop { + my $self = shift; + + croak "DepTracer is not active" unless $ACTIVE; + croak "Different DepTracer is active" unless "$ACTIVE" eq "$self"; + $ACTIVE = undef; + + $self->{+_ON} = 0; + + my $inc = $self->{+_MY_INC} or return 0; + + @INC = grep { !(ref($_) && $inc == $_) } @INC; + return 0; +} + +sub my_inc { + my $self = shift; + + return $self->{+_MY_INC} if $self->{+_MY_INC}; + + my $exclude = $self->{+EXCLUDE} ||= {%DEFAULT_EXCLUDE}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + + return $self->{+_MY_INC} ||= sub { + my ($this, $file) = @_; + + return unless $self->{+_ON}; + return unless $file =~ m/^[_a-z]/i; + return if $exclude->{$file}; + + my $loaded_by = $self->loaded_by; + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + + return; + }; +} + +sub clear_loaded { %{$_[0]->{+LOADED}} = () } + +my %REQUIRE_CACHE; + +sub add_callbacks { + my $self = shift; + my %watch = @_; + for my $file (keys %watch) { + my $cb = $watch{$file}; + $self->add_callback($file => $cb); + } +} + +sub add_callback { + my $self = shift; + my ($file, $cb) = @_; + $self->{+LOADED}->{$file}++; + $self->{+CALLBACKS}->{$file} = $cb; +} + +sub init { + my $self = shift; + + my $exclude = $self->{+EXCLUDE} ||= { %DEFAULT_EXCLUDE }; + + my $stash = \%CORE::GLOBAL::; + # We use a string in the reference below to prevent the glob slot from + # being auto-vivified by the compiler. + $self->{+REAL_REQUIRE} = exists $stash->{require} ? \&{'CORE::GLOBAL::require'} : undef; + + $self->{+CALLBACKS} //= {}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + my $inc = $self->my_inc; + + my $require = $self->{+MY_REQUIRE} = sub { + my ($file) = @_; + + my $loaded_by = $self->loaded_by; + + my $real_require = $self->{+REAL_REQUIRE}; + unless($real_require) { + my $caller = $loaded_by->[0]; + $real_require = $REQUIRE_CACHE{$caller} ||= eval "package $caller; sub { CORE::require(\$_[0]) }" or die $@; + } + + goto &$real_require unless $self->{+_ON}; + + if ($file =~ m/^[_a-z]/i) { + unless ($exclude->{$file}) { + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + } + } + + if (!ref($INC[0]) || $INC[0] != $inc) { + @INC = ( + $inc, + grep { !(ref($_) && $inc == $_) } @INC, + ); + } + + local @INC = @INC[1 .. $#INC]; + + $real_require->(@_); + }; + + { + no strict 'refs'; + no warnings 'redefine'; + *{'CORE::GLOBAL::require'} = $require; + } +} + +sub loaded_by { + my $level = 1; + + while(my @caller = caller($level++)) { + next if $caller[0] eq __PACKAGE__; + + return [$caller[0], $caller[1]]; + } + + return ['', '']; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::DepTracer - Tool for tracing module dependencies as +they are loaded. + +=head1 DESCRIPTION + +This tool is used by Test2::Harness to build a graph of dependancies which can +then be used to blacklist modified modules (and anything thatuses them) when +they change under a preloaded runner. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::DepTracer; + + my $dt = Test2::Harness::Runner::DepTracer->new(); + + $dt->start(); + + require Some::Thing; + + # You can always check for and retrieve an active DepTrace this way: + my $dt_reference = Test2::Harness::Runner::DepTracer->ACTIVE; + + $dt->stop(); + + my $dep_map = $dt->dep_map; + + my $loaded_by = $dep_map->{'Some/Thing.pm'}; + print "Some::Thing was directly or indirectly loaded by:\n" . join("\n" => @$loaded_by) . "\n"; + +=head1 ATTRIBUTES + +These can be specified at construction, and will be populated during use. + +=over 4 + +=item $hashref = $dt->exclude + +A hashref of files/modules to exclude from dep tracking. By default C<strict> +and C<warnings> are excluded. + +=item $hashref = $dt->dep_map + +Every file which is loaded while the tool is started will have an entry in this +hash, each value is an array of all files which loaded the key file directly or +indirectly. + +=item $hashref = $dt->loaded + +How many times each file was directly loaded. + +=back + +=head1 METHODS + +=over 4 + +=item $dt->start + +Start tracking modules which are loaded. + +=item $dt->stop + +Stop tracking moduels that are loaded. + +=back + +=head1 CLASS METHODS + +=over 4 + +=item $dt_or_undef = Test2::Harness::Runner::DepTracer->ACTIVE(); + +Get the currently active DepTracer, if any. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Job.pm b/libold2/Test2/Harness/Runner/Job.pm new file mode 100644 index 000000000..ec2378382 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Job.pm @@ -0,0 +1,828 @@ +package Test2::Harness::Runner::Job; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess croak/; +use Config qw/%Config/; +use List::Util qw/min/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/CAN_REALLY_FORK/; +use Time::HiRes qw/time/; + +use File::Spec(); +use File::Temp(); + +use Test2::Harness::Util qw/fqmod clean_path write_file_atomic write_file mod2file open_file parse_exit process_includes chmod_tmp/; +use Test2::Harness::IPC; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase( + qw{ <task <runner <run <settings }, # required + qw{ + <fork_callback + <last_output_size + +output_changed + + +verbose + + +via + + +run_dir +job_dir +tmp_dir +event_dir + + +ch_dir +unsafe_inc + + +use_fork +use_w_switch + + +includes +runner_includes + +switches + +use_stream + +cli_includes + +cli_options + + +smoke + +retry +retry_isolated +is_try + + +args +file +run_file + + +out_file +err_file +in_file +bail_file + + +load +load_import + + +event_uuids +mem_usage +io_events + + +env_vars + + +event_timeout +post_exit_timeout +use_timeout + + +switches_from_env + + +et_file +pet_file + + +min_slots + +max_slots + } +); + +sub category { 'job' } + +sub init { + my $self = shift; + + croak "'runner' is a required attribute" unless $self->{+RUNNER}; + croak "'run' is a required attribute" unless $self->{+RUN}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + delete $self->{+JOB_DIR}; + + # Avoid a ref cycle + #weaken($self->{+RUNNER}); + + my $task = $self->{+TASK} or croak "'task' is a required attribute"; + + delete $self->{+LAST_OUTPUT_SIZE}; + + confess "Task does not have a job ID" unless $task->{job_id}; + confess "Task does not have a file" unless $task->{file}; +} + +sub job_id { $_[0]->{+TASK}->{job_id} } + +sub prepare_dir { + my $self = shift; + + $self->job_dir(); + $self->tmp_dir(); + $self->event_dir(); +} + +sub via { + my $self = shift; + + return undef if $self->{+SETTINGS}->debug->dummy; + return undef if $self->{+TASK}->{resource_skip}; + + return $self->{+VIA} if exists $self->{+VIA}; + + my $task = $self->{+TASK}; + return $self->{+VIA} = $task->{via} if $task->{via}; + + return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork; + + return $self->{+VIA} = undef; +} + +sub spawn_params { + my $self = shift; + + my $task = $self->{+TASK}; + + my $skip; + $skip = 'dummy mode' if $self->{+SETTINGS}->debug->dummy; + $skip = "Some resources are not available: " . join(', ' => @{$self->{+TASK}->{resource_skip}}) if $self->{+TASK}->{resource_skip}; + + my $command; + if (!$skip && $task->{binary} || $task->{non_perl}) { + my $file = $self->ch_dir ? $self->file : $self->rel_file; + $command = [clean_path($file), $self->args]; + } + else { + $command = [ + $^X, + $self->cli_includes, + $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (), + $self->switches, + $self->cli_options, + + $skip ? ('-e', "print \"1..0 # SKIP $skip\"") : (sub { $self->run_file }), + + $self->args, + ]; + } + + my $out_fh = open_file($self->out_file, '>'); + my $err_fh = open_file($self->err_file, '>'); + my $in_fh = open_file($self->in_file, '<'); + + return { + command => $command, + stdin => $in_fh, + stdout => $out_fh, + stderr => $err_fh, + chdir => $self->ch_dir(), + env => $self->env_vars(), + }; +} + +sub switches_from_env { + my $self = shift; + + return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV}; + + return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES}; + + return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]}; +} + +my %JSON_SKIP = ( + SETTINGS() => 1, + TASK() => 1, + RUNNER() => 1, + RUN() => 1, + CLI_INCLUDES() => 1, + CLI_OPTIONS() => 1, + ERR_FILE() => 1, + ET_FILE() => 1, + EVENT_DIR() => 1, + EXIT() => 1, + EXIT_TIME() => 1, + IN_FILE() => 1, + JOB_DIR() => 1, + LAST_OUTPUT_SIZE() => 1, + OUT_FILE() => 1, + BAIL_FILE() => 1, + OUTPUT_CHANGED() => 1, + PET_FILE() => 1, + RUN_DIR() => 1, + TMP_DIR() => 1, +); + +sub TO_JSON { + my $self = shift; + + my $out = { %{$self->{+TASK}} }; + + for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) { + next if $JSON_SKIP{$attr}; + $self->$attr unless defined $self->{$attr}; + $out->{$attr} = $self->{$attr}; + } + + delete $out->{+FORK_CALLBACK}; + delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE'; + + $out->{job_name} //= $out->{job_id}; + $out->{abs_file} = clean_path($self->file); + + return $out; +} + +sub run_file { + my $self = shift; + return $self->{+RUN_FILE} //= $self->rel_file; +} + +sub rel_file { File::Spec->abs2rel($_[0]->file) } +sub file { $_[0]->{+FILE} //= clean_path($_[0]->{+TASK}->{file}, 0) } +sub err_file { $_[0]->{+ERR_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) } +sub out_file { $_[0]->{+OUT_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) } +sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) } +sub et_file { $_[0]->{+ET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) } +sub pet_file { $_[0]->{+PET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) } +sub run_dir { $_[0]->{+RUN_DIR} //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) } + +sub bailed_out { + my $self = shift; + + if(-f $self->bail_file) { + my $fh = open_file($self->bail_file, '<'); + my $reason = <$fh> || 1; + return $reason; + } + + my $fh = open_file($self->out_file, '<'); + while (my $line = <$fh>) { + next unless $line =~ m/^Bail out!\s*(.*)$/; + return $1 || 1; + } + + return ""; +} + +sub output_size { + my $self = shift; + + my $size = 0; + + $size += -s $self->err_file || 0; + $size += -s $self->out_file || 0; + + return $self->{+LAST_OUTPUT_SIZE} = $size; +} + +sub output_changed { + my $self = shift; + + my $last = $self->{+LAST_OUTPUT_SIZE}; + my $size = $self->output_size(); + + # Output changed, update time + return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last; + + # Return the last recorded time, if there is no previously recorded time then the record starts now + return $self->{+OUTPUT_CHANGED} //= time(); +} + +sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 } +sub is_try { $_[0]->{+IS_TRY} //= $_[0]->{+TASK}->{is_try} // 0 } +sub ch_dir { $_[0]->{+CH_DIR} //= $_[0]->{+TASK}->{ch_dir} // '' } +sub unsafe_inc { $_[0]->{+UNSAFE_INC} //= $_[0]->{+RUNNER}->unsafe_inc } +sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids } +sub mem_usage { $_[0]->{+MEM_USAGE} //= $_[0]->run->mem_usage } + +sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) } + +sub smoke { $_[0]->{+SMOKE} //= $_[0]->_fallback(smoke => 0, qw/task/) } +sub retry_isolated { $_[0]->{+RETRY_ISOLATED} //= $_[0]->_fallback(retry_isolated => 0, qw/task run/) } +sub use_stream { $_[0]->{+USE_STREAM} //= $_[0]->_fallback(use_stream => 1, qw/task run/) } +sub use_timeout { $_[0]->{+USE_TIMEOUT} //= $_[0]->_fallback(use_timeout => 1, qw/task/) } +sub retry { $_[0]->{+RETRY} //= $_[0]->_fallback(retry => undef, qw/task run/) } +sub event_timeout { $_[0]->{+EVENT_TIMEOUT} //= $_[0]->_fallback(event_timeout => undef, qw/task runner/) } +sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) } + +sub min_slots { $_[0]->{+MIN_SLOTS} //= $_[0]->_fallback_non_bool(min_slots => 1, qw/task/) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_fallback_non_bool(max_slots => 1, qw/task/) } + +sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} } +sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} } + +sub cli_includes { + my $self = shift; + + # '.' is handled via the PERL_USE_UNSAFE_INC env var set later + $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes]; + + return @{$self->{+CLI_INCLUDES}}; +} + +sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} } + +sub _merge_sources { + my $self = shift; + my ($name, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + next unless defined $val; + next unless @$val; + push @vals => @$val; + } + + return \@vals; +} + +sub _fallback_non_bool { + my $self = shift; + my ($name, $default, @from) = @_; + + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + return $val if defined $val; + } + + return $default; +} + +sub _fallback { + my $self = shift; + my ($name, $default, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + push @vals => $val if defined $val; + } + + return $default unless @vals; + + # If the default is a ref we will just return the first value we found, truthiness check is useless + return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/; + + # If the default is true, then we only return true if none of the vals are false + return !grep { !$_ } @vals if $default; + + # If the default is false, then we return true if any of the valse are true + return grep { $_ } @vals; +} + +sub job_dir { + my $self = shift; + return $self->{+JOB_DIR} if $self->{+JOB_DIR}; + + my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try); + mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!"; + chmod_tmp($job_dir); + $self->{+JOB_DIR} = $job_dir; +} + +sub tmp_dir { + my $self = shift; + + return $self->{+TMP_DIR} if $self->{+TMP_DIR}; + + my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir); + chmod_tmp($tmp_dir); + + $self->{+TMP_DIR} = clean_path($tmp_dir); +} + +sub make_event_dir { $_[0]->event_dir } +sub event_dir { + my $self = shift; + return $self->{+EVENT_DIR} if $self->{+EVENT_DIR}; + + my $events_dir = File::Spec->catdir($self->job_dir, 'events'); + unless (-d $events_dir) { + mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!"; + } + $self->{+EVENT_DIR} = $events_dir; +} + +sub in_file { + my $self = shift; + return $self->{+IN_FILE} if $self->{+IN_FILE}; + + my $task = $self->{+TASK}; + + unless ($task->{input}) { + my $from_run = $self->run->input_file; + return $self->{+IN_FILE} = $from_run if $from_run; + } + + my $stdin = File::Spec->catfile($self->job_dir, 'stdin'); + + my $content = $task->{input} // $self->run->input // ''; + write_file($stdin, $content); + + return $self->{+IN_FILE} = $stdin; +} + +sub use_fork { + my $self = shift; + + return $self->{+USE_FORK} if defined $self->{+USE_FORK}; + + my $task = $self->{+TASK}; + + return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK; + return $self->{+USE_FORK} = 0 if $task->{binary}; + return $self->{+USE_FORK} = 0 if $task->{non_perl}; + return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork}; + return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload}; + + # -w switch is ok, otherwise it is a no-go + return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches; + + my $runner = $self->{+RUNNER}; + return $self->{+USE_FORK} = 0 unless $runner->use_fork; + + return $self->{+USE_FORK} = 1; +} + +sub includes { + my $self = shift; + + return @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + $self->{+INCLUDES} = [ + process_includes( + list => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + $self->ch_dir ? (ch_dir => $self->ch_dir) : (), + ) + ]; + + return @{$self->{+INCLUDES}}; +} + +sub cli_options { + my $self = shift; + + my $event_dir = $self->event_dir; + my $job_id = $self->job_id; + + return ( + $self->use_stream ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (), + $self->event_uuids ? ('-MTest2::Plugin::UUID') : (), + $self->mem_usage ? ('-MTest2::Plugin::MemUsage') : (), + $self->io_events ? ('-MTest2::Plugin::IOEvents') : (), + (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import), + (map { "-m$_" } $self->load), + ); +} + +sub switches { + my $self = shift; + + return @{$self->{+SWITCHES}} if $self->{+SWITCHES}; + + my @switches; + + my %seen; + for my $s (@{$self->{+TASK}->{switches} // []}) { + $seen{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + my %seen2; + for my $s (@{$self->{+RUNNER}->switches // []}) { + next if $seen{$s}; + $seen2{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + for my $s ($self->switches_from_env) { + next if $seen{$s}; + next if $seen2{$s}; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + return @{$self->{+SWITCHES} = \@switches}; +} + +sub prof_file { + my $self = shift; + my $file =$self->rel_file; + + $file =~ s{/}{-}g; + $file =~ s{\.[^\.]+$}{.nytprof}g; + + return $file; +} + +sub env_vars { + my $self = shift; + + return $self->{+ENV_VARS} if $self->{+ENV_VARS}; + + my $from_run = $self->run->env_vars; + my $from_task = $self->{+TASK}->{env_vars}; + + my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB}); + push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl}; + push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB}; + my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l; + + my $verbose = $self->verbose; + + return $self->{+ENV_VARS} = { + $from_run ? (%$from_run) : (), + $from_task ? (%$from_task) : (), + + $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (), + + $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (), + + PERL5LIB => $p5l, + PERL_USE_UNSAFE_INC => $self->unsafe_inc, + TEST2_JOB_DIR => $self->job_dir, + TEST2_RUN_DIR => $self->run_dir, + TMPDIR => $self->tmp_dir, + TEMPDIR => $self->tmp_dir, + SYSTEM_TMPDIR => $self->{+SETTINGS}->harness->orig_tmp, + SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms, + + HARNESS_IS_VERBOSE => $verbose, + T2_HARNESS_IS_VERBOSE => $verbose, + + HARNESS_ACTIVE => 1, + TEST2_HARNESS_ACTIVE => 1, + + T2_HARNESS_JOB_FILE => $self->rel_file, + T2_HARNESS_JOB_NAME => $self->{+TASK}->{job_name}, + T2_HARNESS_JOB_IS_TRY => $self->{+IS_TRY} // 0, + T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '', + }; +} + +sub load_import { + my $self = shift; + + return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT}; + + my $from_run = $self->run->load_import; + + my @out; + for my $mod (@{$from_run->{'@'} // []}) { + push @out => [$mod, $from_run->{$mod} // []]; + } + + return @{$self->{+LOAD_IMPORT} = \@out}; +} + +sub use_w_switch { + my $self = shift; + return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH}; + $self->switches; + return $self->{+USE_W_SWITCH}; +} + +sub set_exit { + my $self = shift; + my ($runner, $exit, $time, @args) = @_; + + $self->SUPER::set_exit(@_); + + my $file = File::Spec->catfile($self->job_dir, 'exit'); + + my $e = parse_exit($exit); + + write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Job - Representation of a test job. + +=head1 DESCRIPTION + +This module takes all the data from a test file queue item, a run, and runner +settings, and mashes them together to figure out what is actually needed to run +a job. + +=head1 METHODS + +Note, this object subclasses L<Test2::Harness::IPC::Process>. + +=over 4 + +=item $arrayref = $job->args + +Get the arguments for the test either formt he queue item, or from the run. + +=item $path = $job->bail_file + +Path to the events-file used in case of a bail-out + +=item $bool = $job->bailed_out + +True if the test job bailed out. + +=item $cat $job->category + +Process category, always 'job' unless overriden in a subclass. + +=item $path = $job->ch_dir + +If this job first requires a change in directory before running, this will +return the path. + +=item @list = $job->cli_includes + +List of includes for a command line launch of this job. + +=item @list = $job->cli_options + +List of options for a command line launch of this job. + +=item $hashref = $job->env_vars + +Get environment variables to set when launching this job. + +=item $path = $job->out_file + +File to which all STDOUT for the job will be written. + +=item $path = $job->err_file + +File to which all STDERR for the job will be written. + +=item $path = $job->et_file + +File to which event timeout notifications will be written. + +=item $path = $job->pet_file + +File to which post exit timeout events will be written. + +=item $path = $job->event_dir + +Directory to which L<Test2::Formatter::Stream> events will be written. + +=item $time = $job->event_timeout + +Event timeout specification, if any, first from test queue item, then from +runner. + +=item $time = $job->post_exit_timeout + +Post exit timeout specification, if any, first from test queue item, then from +runner. + +=item $bool = $job->event_uuids + +Use L<Test2::Plugin::UUID> inside the test. + +=item $path = $job->file + +Test file the job will be running. + +=item $coderef = $job->fork_callback + +If the job is to be launched via fork, use this callback. + +=item $path = $job->in_file + +File containing STDIN to be provided to the test. + +=item @list = $job->includes + +Paths to add to @INC for the test. + +=item $bool = $job->io_events + +True if L<Test2::Plugin::IOEvents> should be used. + +=item $int = $job->is_try + +This starts at 0 and will be incremented for every retry of the job. + +=item $path = $job->job_dir + +Temporary directory housing all files related to this job when it runs. + +=item $uuid = $job->job_id + +UUID for this job. + +=item @list = $job->load + +Modules to load when starting this job. + +=item @list = $job->load_import + +Modules to load and import when starting this job. + +=item $bool = $job->mem_usage + +True if the L<Test2::Plugin::MemUsage> plugin should be used. + +=item $path = $job->run_file + +Usually the same as rel_file, but you can specify an alternative file to +actually run. + +=item $path = $job->rel_file + +Relative path to the file. + +=item $int = $job->retry + +How many times the test should be retried if it fails. + +=item $bool = $job->retry_isolated + +True if the test should be retried in isolation if it fails. + +=item $run = $job->run + +The L<Test2::Harness::Runner::Run> instance. + +=item $path = $job->run_dir + +Path to the temporary directory housing all the data about the run. + +=item $runner = $job->runner + +The L<Test2::Harness::Runner> instance. + +=item @list = $job->runner_includes + +Search path includes provided directly by the runner. + +=item $settings = $job->settings + +The L<Test2::Harness::Settings> instance. + +=item $bool = $job->smoke + +True if the test is a priority smoke test. + +=item $hashref = $job->spawn_params + +Parameters for C<run_cmd()> in L<Test2::Harness::Util::IPC> when launching this +job. + +=item @list = $job->switches + +Command line switches for perl when running this test. + +=item $hashref = $job->task + +Task data from the queue. + +=item $path = $job->tmp_dir + +Temp dir created specifically for this job. + +=item $bool = $job->unsafe_inc + +True if '.' should be added to C<@INC>. + +=item $bool = $job->use_fork + +True if this job should be launched via fork. + +=item $bool = $job->use_stream + +True if this job should use L<Test2::Formatter::Stream>. + +=item $bool = $job->use_timeout + +True if this job should timeout due to lack of activity. + +=item $bool = $job->use_w_switch + +True if the C<-w> switch should be used for this test. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Preload.pm b/libold2/Test2/Harness/Runner/Preload.pm new file mode 100644 index 000000000..f09708fc7 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Preload.pm @@ -0,0 +1,569 @@ +package Test2::Harness::Runner::Preload; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Runner::Preload::Stage(); + +sub import { + my $class = shift; + my $caller = caller; + + my %exports; + + my $instance = $class->new; + + $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; + + $exports{stage} = sub { + my ($name, $code) = @_; + my @caller = caller(); + $instance->build_stage( + name => $name, + code => $code, + caller => \@caller, + ); + }; + + $exports{eager} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_eager(1); + }; + + $exports{default} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + my $name = $stage->name; + $instance->set_default_stage($name); + }; + + $exports{file_stage} = sub { + my ($callback) = @_; + my @caller = caller(); + croak "'file_stage' cannot be used under a stage" if @{$instance->stack}; + $instance->add_file_stage(\@caller, $callback); + }; + + for my $name (qw/pre_fork post_fork pre_launch/) { + my $meth = "add_${name}_callback"; + $exports{$name} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->$meth(@_); + }; + } + + $exports{watch} = sub { + if (@{$instance->stack}) { + my $stage = $instance->stack->[-1]; + return $stage->watch(@_); + } + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + return $active->add_callback(@_); + } + } + + croak "No current stage, and no active deptracer"; + }; + + $exports{preload} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->add_to_load_sequence(@_); + }; + + $exports{reload_remove_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_remove_check(@_); + }; + + $exports{reload_inplace_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_inplace_check(@_); + }; + + for my $name (keys %exports) { + no strict 'refs'; + *{"$caller\::$name"} = $exports{$name}; + } +} + +use Test2::Harness::Util::HashBase qw{ + <stage_list + <stage_lookup + <stack + +default_stage + +file_stage +}; + +sub init { + my $self = shift; + + $self->{+STAGE_LIST} //= []; + $self->{+STAGE_LOOKUP} //= {}; + + $self->{+STACK} //= []; + + $self->{+FILE_STAGE} //= []; +} + +sub build_stage { + my $self = shift; + my %params = @_; + + my $caller = $params{caller} //= [caller()]; + + die "A coderef is required at $caller->[1] line $caller->[2].\n" + unless $params{code}; + + my $stage = Test2::Harness::Runner::Preload::Stage->new( + stage_lookup => $self->{+STAGE_LOOKUP}, + %params, + ); + + my $stack = $self->{+STACK} //= []; + push @$stack => $stage; + + my $ok = eval { $params{code}->($stage); 1 }; + my $err = $@; + + die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; + + pop @$stack; + + die $err unless $ok; + + if (@$stack) { + $stack->[-1]->add_child($stage); + } + else { + $self->add_stage($stage, $caller); + } + + return $stage; +} + +sub add_stage { + my $self = shift; + my ($stage, $caller) = @_; + + $caller //= [caller()]; + + my @all = ($stage, @{$stage->all_children}); + + for my $item (@all) { + my $name = $item->name; + + if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { + $caller //= [caller()]; + my $ncaller = $item->frame; + my $ecaller = $existing->frame; + die <<" EOT" +A stage named '$name' was already defined. + First at $ecaller->[1] line $ecaller->[2]. + Second at $ncaller->[1] line $ncaller->[2]. + Mixed at $caller->[1] line $caller->[2]. + EOT + } + + $self->{+STAGE_LOOKUP}->{$name} = $item; + } + + push @{$self->{+STAGE_LIST}} => $stage; +} + +sub merge { + my $self = shift; + my ($merge) = @_; + + my $caller = [caller()]; + + for my $stage (@{$merge->{+STAGE_LIST}}) { + $self->add_stage($stage, $caller); + } + + push @{$self->{+FILE_STAGE}} => @{$merge->{+FILE_STAGE}}; + + $self->{+DEFAULT_STAGE} //= $merge->default_stage; +} + +sub add_file_stage { + my $self = shift; + my ($caller, $code) = @_; + + croak "Caller must be defined and an array" unless $caller && ref($caller) eq 'ARRAY'; + croak "Code must be defined and a coderef" unless $code && ref($code) eq 'CODE'; + + push @{$self->{+FILE_STAGE}} => [$caller, $code]; +} + +sub file_stage { + my $self = shift; + my ($file) = @_; + + for my $cb (@{$self->{+FILE_STAGE}}) { + my ($caller, $code) = @$cb; + my $stage = $code->($file) or next; + + die "file_stage callback returned invalid stage: $stage at $caller->[1] line $caller->[2].\n" + unless $self->{+STAGE_LOOKUP}->{$stage}; + + return $stage; + } + + return; +} + +sub default_stage { + my $self = shift; + return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; + return $self->{+STAGE_LIST}->[0]; +} + +sub set_default_stage { + my $self = shift; + my ($name) = @_; + + croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; + $self->{+DEFAULT_STAGE} = $name; +} + +sub eager_stages { + my $self = shift; + + my %eager; + + for my $root (@{$self->{+STAGE_LIST}}) { + for my $stage ($root, @{$root->all_children}) { + next unless $stage->eager; + $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; + } + } + + return \%eager; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload - DSL for building complex stage-based preload +tools. + +=head1 DESCRIPTION + +L<Test2::Harness> allows you to preload libraries for a performance boost. This +module provides tools that let you go beyond that and build a more complex +preload. In addition you can build multiple preload I<stages>, each stage will +be its own process and tests can run from a specific stage. This allows for +multiple different preload states from which to run tests. + +=head1 SYNOPSIS + +=head2 USING YOUR PRELOAD + +The C<-P> or C<--preload> options work for custom preload modules just as they +do regular modules. Yath will know the difference and act accordingly. + + yath test -PMy::Preload + +=head2 WRITING YOUR PRELOAD + + package My::Preload; + use strict; + use warnings; + + # This imports several useful tools, and puts the necessary meta-data in + # your package to identify it as a special preload. + use Test2::Harness::Runner::Preload; + + # You must specify at least one stage. + stage Moose => sub { + # Preload can be called multiple times, and can load multiple modules + # per call. Order is preserved. + preload 'Moose', 'Moose::Role'; + preload 'Scalar::Util', 'List::Util'; + + # preload can also be given a sub if you have some custom code to run + # at a specific point in the load order + preload sub { + # Do something before loading Try::Tiny + ... + }; + + preload 'Try::Tiny'; + + # Tell the runner to watch this file for changes, if it does change run + # the sub instead of the usual reload process. This lets you reload + # configs and other non-perl files, or allows you to use a custom + # reload sub for perl files. + watch 'path/to/file' => sub { ... }; + + # You can also use watch inside preload subs: + preload sub { + watch 'path/to/file' => sub { ... }; + }; + + # In app code you can add watches dynamically when applicable: + preload sub { + ... # inside app code + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + $active->add_callback('path/to/file' => sub { ... }); + } + } + + ... + }; + + # Eager means tests from nested stages can be run in this stage as + # well, this is useful if the nested stage takes a long time to load as + # it allows yath to start running tests sooner instead of waiting for + # the stage to finish loading. Once the nested stage is loaded tests + # intended for it will start running from it instead. + eager(); + + # default means this stage is the one to use if the test does not + # specify a stage. + default(); + + # These are hooks that let you run arbitrary code at specific points in + # the process. pre_fork happens just before forking to run a test. + # post_fork happens just after forking for a test. pre_launch happens + # as late as possible before the test starts executing (post fork, + # after $0 and other special state are reset). + pre_fork sub { ... }; + post_fork sub { ... }; + pre_launch sub { ... }; + + # Stages can be nested, nested ones build off the previous stage, but + # are in a forked process to avoid contaminating the parent. + stage Types => sub { + preload 'MooseX::Types'; + }; + }; + + # Alternative stage that loads Moo instead of Moose + stage Moo => sub { + preload 'Moo'; + + ... + }; + +=head2 HARNESS DIRECTIVES IN PRELOADS + +If you use a staged preload, and the --reload option, you can add 'CHURN' +directives to files in order to only reload sections you are working on. This +is particularly useful when a file cannot be reloaded in full, or when doing so +is expensive. You can wrap subroutines in the churn directives to have yath +reload only those subroutines. + + sub do_not_reload_this { ... { + + # HARNESS-CHURN-START + + sub reload_this_one { + ... + } + + sub reload_this_one_too { + ... + } + + # HARNESS-CHURN-STOP + + sub this_is_not_reloaded { ... } + +You can put as many churn sections you want in as many preloaded modules as you +want. If a change is detected then only the churn sections will be reloaded. +The churn sections are reloaded by taking the source between the start and stop +markers, and running them in an eval like this: + + eval <<EOT + package MODULE_FROM_FILENAME; + use strict; + use warnings; + no warnings 'redefine'; + #line $line_number $file + $YOUR_CODE + ;1; + EOT + +In most cases this is sufficient to replace the old sub with the new one. If +the automatically determined package is not correct you can add a C<package +FOO;> statement inside the markers. If the strict/warnings settings are not to +your specifications you can add overrides inside the markers. Any valid perl +code can go into the markers. + +B<CAVEATS:> Be aware they do not have their original scope, and that can lead +to problems if you are not paying attention. Variables outside your markers are +not accessible, and lexical variables put inside your markers will be "new" on +each reload, this can cause confusion if you have lexicals used by multiple +subs where some are inside churn blocks and others are not, so best not to do +that. Package variables work a bit better, but any assignment lines are re-run. +So C<our $FOO;> is fine (it does not change the value if it is set) but +C<our $FOO = ...> will reset the var on each reload. + +=head1 EXPORTS + +=over 4 + +=item $meta = TEST2_HARNESS_PRELOAD() + +=item $meta = $class->TEST2_HARNESS_PRELOAD() + +This export provides the meta object, which is an instance of this class. This +method being present is how Test2::Harness differentiates between a regular +module and a special preload library. + +=item stage NAME => sub { ... } + +This creates a new stage with the given C<NAME>, and then runs the coderef with +the new stage set as the I<active> one upon which the other function here will +operate. Once the coderef returns the I<active> stage is cleared. + +You may nest stages by calling this function again inside the codeblock. + +B<NOTE:> stage names B<ARE> case sensitive. This can be confusing when you +consider that most harness directives are all-caps. In the following case the +stage requested by the test and the stage defined in +the library are NOT the same. + +In a test file: + + # HARNESS-STAGE-FOO + +In a preload library: + + stage foo { ... } + +Harness directives are all-caps, however the user data portion need not be, +this is fine: + + # HARNESS-STAGE-foo + +However it is very easy to make the mistake of thinking it is case insensitive. +It is also easy to assume the 'foo' part of the harness directive must be all +caps. In many cases it is smart to make your stage names all-caps. + +=item preload $module_name + +=item preload @module_names + +=item preload sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +This adds modules to the list of libraries to preload. Order is preserved. You +can also add coderefs to execute arbitrary code between module loads. + +The coderef is called with no arguments, and its return is ignored. + +=item eager() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This marks the I<active> stage as being I<eager>. An eager stage will start +running tests for nested stages if it finds itself with no tests of its own to +run before the nested stage can finish loading. The idea here is to avoid +unused test slots when possible allowing for tests to complete sooner. + +=item default() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This B<MUST> be called only once across C<ALL> stages in a given library. + +If multiple preload libraries are loaded then the I<first> default set (based +on load order) will be the default, others will notbe honored. + +=item $stage_name = file_stage($test_file) + +This is optional. If defined this callback will have a chance to look at all +files that are going to be run and assign them a stage. This may return undef +or an empty list if it does not have a stage to assign. + +If multiple preload libraries define file_stage callbacks they will be called +in order, the first one to return a stage name will win. + +If no file_stage callbacks provide a stage for a file then any harness +directives declaring a stage will be honored. If no stage is ever assigned then +the test will be run int he default stage. + +=item pre_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before the preload-stage process forks to run the +test. Note that any state changes here can effect future tests to be run. + +=item post_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just after the preload-stage process forks to run the +test. This is run as early as possible, things like C<$0> may not be set +properly yet. + +=item pre_launch sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before control of the test process is turned over +to the test file itself. This is run as late as possible, so things like C<$0> +should be set properly. + +=back + +=head1 META-OBJECT + +This class is also the meta-object used to construct a preload library. The +methods are left undocumented as this is an implementation detail and you are +not intended to directly use this object. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Preload/Stage.pm b/libold2/Test2/Harness/Runner/Preload/Stage.pm new file mode 100644 index 000000000..abba7a828 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Preload/Stage.pm @@ -0,0 +1,159 @@ +package Test2::Harness::Runner::Preload::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <name + <frame + <children + <pre_fork_callbacks + <post_fork_callbacks + <pre_launch_callbacks + <load_sequence + <watches + eager + reload_remove_check + reload_inplace_check +}; + +sub init { + my $self = shift; + + $self->{+FRAME} //= [caller(1)]; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; + croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; + + $self->{+CHILDREN} //= []; + + $self->{+PRE_FORK_CALLBACKS} //= []; + $self->{+POST_FORK_CALLBACKS} //= []; + $self->{+PRE_LAUNCH_CALLBACKS} //= []; + + $self->{+LOAD_SEQUENCE} //= []; + $self->{+WATCHES} //= {}; +} + +sub watch { + my $self = shift; + my ($file, $callback) = @_; + croak "The first argument must be a file" unless $file && -f $file; + croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; + croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; + + $self->{+WATCHES}->{$file} = $callback; + return; +} + +sub all_children { + my $self = shift; + + my @out = @{$self->{+CHILDREN}}; + + for (my $i = 0; $i < @out; $i++) { + my $it = $out[$i]; + push @out => @{$it->children}; + } + + return \@out; +} + +sub add_child { + my $self = shift; + my ($stage) = @_; + push @{$self->{+CHILDREN}} => $stage; +} + +sub add_pre_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; +} + +sub add_post_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+POST_FORK_CALLBACKS}} => $cb; +} + +sub add_pre_launch_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; +} + +sub add_to_load_sequence { + my $self = shift; + + for my $item (@_) { + croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" + unless ref($item) eq 'CODE' || !ref($item); + + push @{$self->{+LOAD_SEQUENCE}} => $item; + } + + return @_; +} + +sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } +sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } +sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload::Stage - Abstraction of a preload stage. + +=head1 DESCRIPTION + +This is an implementation detail. You are not intended to directly use/modify +instances of this class. See L<Test2::Harness::Runner::Preload> for +documentation on how to write a custom preload library. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Preloader.pm b/libold2/Test2/Harness/Runner/Preloader.pm new file mode 100644 index 000000000..5bce0871b --- /dev/null +++ b/libold2/Test2/Harness/Runner/Preloader.pm @@ -0,0 +1,665 @@ +package Test2::Harness::Runner::Preloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use B(); +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use Time::HiRes qw/time sleep/; +use Test2::Harness::Util qw/open_file file2mod mod2file lock_file unlock_file clean_path/; + +use Test2::Harness::Runner::Reloader; +use Test2::Harness::Runner::Preloader::Stage; + +use File::Spec(); +use List::Util qw/pairgrep/; + +use Test2::Harness::Util::HashBase( + qw{ + <dir + <preloads + <done + <below_threshold + + <dtrace <reloader + + <staged <started_stages <stage + + <dump_depmap + <changed + <restrict_reload + + <blacklist_file + <blacklist_lock + <blacklist + + <monitored + }, + + '<monitor', # This means watch for changes, restart stage if any found + '<reload', # Try to reload in place instead of restart stage +); + +sub init { + my $self = shift; + + $self->{+PRELOADS} //= []; + + $self->{+BELOW_THRESHOLD} //= 0; + + return if $self->{+BELOW_THRESHOLD}; + + $self->{+MONITOR} = 1 if $self->{+RELOAD}; + + my $need_depmap = $self->{+RELOAD} || $self->{+MONITOR} || $self->{+DUMP_DEPMAP}; + + if ($need_depmap) { + require Test2::Harness::Runner::DepTracer; + $self->{+DTRACE} //= Test2::Harness::Runner::DepTracer->new(); + } + + if ($self->{+MONITOR} || $self->{+RELOAD}) { + $self->{+BLACKLIST} //= {}; + $self->{+BLACKLIST_FILE} //= File::Spec->catfile($self->{+DIR}, 'BLACKLIST'); + } + + $self->{+RELOADER} = Test2::Harness::Runner::Reloader->new( + stat_min_gap => 2, + notify_cb => sub { $self->_reload_cb_notify(@_) }, + find_loaded_cb => sub { $self->_reload_cb_find_loaded(@_) }, + should_watch_cb => sub { $self->_reload_cb_should_watch(@_) }, + can_reload_cb => sub { $self->_reload_cb_can_reload(@_) }, + reload_cb => sub { $self->_reload_cb_reload(@_) }, + delete_symbol_cb => sub { $self->_reload_cb_delete_symbol(@_) }, + ); +} + +sub stage_check { + my $self = shift; + my ($stage) = @_; + + return 0 if $self->{+BELOW_THRESHOLD}; + + my $p = $self->{+STAGED} or return 0; + return 1 if $stage eq 'NOPRELOAD'; + return 1 if $p->stage_lookup->{$stage}; + return 0; +} + +sub task_stage { + my $self = shift; + my ($file, $wants) = @_; + + $wants //= ""; + + return 'default' if $self->{+BELOW_THRESHOLD}; + return 'default' unless $self->{+STAGED}; + + return $wants if $wants && $self->stage_check($wants); + + my $stage = $self->{+STAGED}->file_stage($file) // $self->{+STAGED}->default_stage; + + return $stage; +} + +sub preload { + my $self = shift; + + croak "Already preloaded" if $self->{+DONE}; + + return 'default' if $self->{+BELOW_THRESHOLD}; + + my $preloads = $self->{+PRELOADS} or return 'default'; + return 'default' unless @$preloads; + + require Test2::API; + Test2::API::test2_start_preload(); + + # Not loading blacklist yet because any preloads in this list need to + # happen regardless of the blacklist. + if ($self->{+MONITOR} || $self->{+DTRACE}) { + $self->_monitor_preload($preloads); + } + else { + $self->_preload($preloads); + } + + $self->{+DONE} = 1; +} + +sub preload_stages { + my $self = shift; + return 'default' unless $self->{+STAGED}; + return $self->_preload_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); +} + +sub _preload_stages { + my $self = shift; + my @stages = @_; + + my $name = 'base'; + my @procs; + + while (my $stage = shift @stages) { + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $proc = $self->launch_stage($stage); + + if ($proc) { + push @procs => $proc; + next; + } + + # We are in the stage now, reset these + if (ref $stage) { + $name = $stage->name; + @procs = (); + @stages = @{$stage->children}; + } + else { # NOPRELOAD + $name = $stage; + @procs = (); + @stages = (); + } + + $self->start_stage($stage); + } + + return($name, @procs); +} + +sub launch_stage { + my $self = shift; + my ($stage) = @_; + + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $name = ref($stage) ? $stage->name : $stage; + + my $pid = fork(); + + return Test2::Harness::Runner::Preloader::Stage->new( + pid => $pid, + name => $name, + ) if $pid; + + $0 .= "-$name"; + $ENV{T2_HARNESS_STAGE} = $name; + + return; +} + +sub start_stage { + my $self = shift; + my ($stage) = @_; + + if ($self->{+STAGED}) { + if ($stage && !ref($stage)) { + $stage = $self->{+STAGED}->stage_lookup->{$stage}; + } + } + else { + $stage = undef; + } + + $self->{+STAGE} = $stage; + + $self->load_blacklist if $self->{+MONITOR}; + + # Localize these in case something we preload tries to modify them. + local $SIG{INT} = $SIG{INT}; + local $SIG{HUP} = $SIG{HUP}; + local $SIG{TERM} = $SIG{TERM}; + + my $preloads = $stage ? $stage->load_sequence : []; + + my $meth = $self->{+MONITOR} || $self->{+DTRACE} ? '_monitor_preload' : '_preload'; + + $self->$meth($preloads, $stage->watches) if $preloads && @$preloads; + + $self->_monitor() if $self->{+MONITOR}; +} + +sub get_stage_callback { + my $self = shift; + my ($name) = @_; + + my $stage = $self->{+STAGE} or return undef; + return undef unless ref $stage; + return $stage->$name; +} + +sub _monitor_preload { + my $self = shift; + my ($preloads, $watch) = @_; + + my $block = {%{$self->blacklist}}; + my $dtrace = $self->dtrace; + + $dtrace->start; + $self->_preload($preloads, $block, $dtrace->my_require); + $dtrace->add_callbacks(%$watch) if $watch; + $dtrace->stop; + + return; +} + +sub _preload { + my $self = shift; + my ($preloads, $block, $require_sub) = @_; + + $block //= {}; + + my %seen; + for my $mod (@$preloads) { + next if $seen{$mod}++; + + if (ref($mod) eq 'CODE') { + next if eval { $mod->($block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + next; + } + + next if $block && $block->{$mod}; + + next if eval { $self->_preload_module($mod, $block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + } + + return; +} + +sub _preload_module { + my $self = shift; + my ($mod, $block, $require_sub) = @_; + + my $file = mod2file($mod); + + $require_sub ? $require_sub->($file) : require $file; + + return unless $mod->can('TEST2_HARNESS_PRELOAD'); + + die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; + + $self->{+STAGED} //= do { + require Test2::Harness::Runner::Preload; + Test2::Harness::Runner::Preload->new(); + }; + + $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); + + return; +} + +sub eager_stages { + my $self = shift; + + return unless $self->{+STAGED}; + return $self->{+STAGED}->eager_stages; +} + +sub load_blacklist { + my $self = shift; + + my $bfile = $self->{+BLACKLIST_FILE}; + my $blacklist = $self->{+BLACKLIST}; + + return unless -f $bfile; + + my $fh = open_file($bfile, '<'); + while(my $pkg = <$fh>) { + chomp($pkg); + $blacklist->{$pkg} = 1; + } +} + +sub _lock_blacklist { + my $self = shift; + + return $self->{+BLACKLIST_LOCK} if $self->{+BLACKLIST_LOCK}; + + my $bl = lock_file($self->{+BLACKLIST_FILE}, '>>'); + seek($bl,2,0); + + return $self->{+BLACKLIST_LOCK} = $bl; +} + +sub _unlock_blacklist { + my $self = shift; + + my $bl = delete $self->{+BLACKLIST_LOCK} or return; + + $bl->flush; + unlock_file($bl); + close($bl); + + return; +} + +sub _notify { + my $self = shift; + for my $msg (@_) { + print "$$ $0 - $msg\n"; + } +} + +sub _reload_cb_notify { + my $self = shift; + my ($type, $info) = @_; + + return $self->_notify("Runner detected a change in one or more preloaded modules...") + if $type eq 'changes_detected'; + + return $self->_notify("Runner detected changes in file '$info'...") + if $type eq 'file_changed'; + + return $self->_notify("Runner attempting to reload '$info->{file}' in place...") + if $type eq 'reload_inplace'; + + return $self->_notify( + "Runner failed to reload '$info->{file}' in place...", + map { split /\n/, $_ } grep { $_ } @{$info->{warnings} // []}, $info->{error}, + ) if $type eq 'reload_fail'; + + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Maxdepth = 2; + return $self->_notify("Runner notification $type: " . (ref($info) ? Data::Dumper::Dumper($info) : $info) . "..."); +} + +sub _reload_cb_find_loaded { keys %{$_[0]->dtrace->loaded} } + +sub _reload_cb_should_watch { + my $self = shift; + my ($reloader, $rel, $abs) = @_; + + my $dirs = $self->{+RESTRICT_RELOAD}; + return 1 unless $dirs && @$dirs; + + for my $dir (@$dirs) { + return 1 if 0 == index($abs, $dir); + } + + return 0; +} + +sub _reload_cb_can_reload { + my $self = shift; + my %params = @_; + + my $mod = $params{module}; + my $file = $params{file}; + + return (0, reason => 'File is a yath preload module') if $mod->can('TEST2_HARNESS_PRELOAD'); + + if (my $cb = $self->get_stage_callback('reload_inplace_check')) { + my ($res, %fields) = $cb->(module => $mod, file => $file); + return ($res, %fields) if defined $res; + } + + return (1) unless $mod->can('import'); + + return (0, reason => 'File is an importer') if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT"}; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT_OK"}; + } + + return (1); +} + +sub find_churn { + my $self = shift; + my ($file) = @_; + + # When a file is saved to disk it seems it can vanish temporarily. Use this loop to wait for it... + my ($fh, $ok, $error); + for (1 .. 50) { + local $@; + $ok = eval { $fh = open_file($file) }; + $error = "LOOP $_: $@"; + last if $ok; + sleep 0.2; + } + + die $error // "Unknown error opening file '$file'" unless $fh; + + my $active = 0; + my @out; + + my $line_no = 0; + while (my $line = <$fh>) { + $line_no++; + + if ($active) { + if ($line =~ m/^\s*#\s*HARNESS-CHURN-STOP\s*$/) { + push @{$out[-1]} => $line_no; + $active = 0; + next; + } + else { + $out[-1][-1] .= $line; + next; + } + } + + if ($line =~ m/^\s*#\s*HARNESS-CHURN-START\s*$/) { + $active = 1; + push @out => [$line_no, '']; + } + } + + return @out; +} + +sub _reload_cb_reload { + my $self = shift; + my %params = @_; + + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my $callbacks; + if (my $dtrace = $self->dtrace) { + $callbacks = $dtrace->callbacks; + } + $callbacks //= {}; + + if (my $cb = $callbacks->{$file} // $callbacks->{$rel}) { + $self->_notify("Changed file '$rel' has a reload callback, executing it instead of regular reloading..."); + my $ret = $cb->(); + return (1, callback_return => $ret); + } + + if (my @churn = $self->find_churn($file)) { + $self->_notify("Changed file '$rel' contains churn sections, running them instead of a full reload..."); + + for my $churn (@churn) { + my ($start, $code, $end) = @$churn; + my $sline = $start + 1; + if (eval "package $mod;\nuse strict;\nuse warnings;\nno warnings 'redefine';\n#line $sline $file\n$code\n ;1;") { + $self->_notify("Success reloading churn block ($file lines $start -> $end)"); + } + else { + $self->_notify("Error reloading churn block ($file lines $start -> $end): $@"); + } + } + + return (1); + } + + return (0, reason => 'reloading disabled') unless $self->{+RELOAD}; + + return undef; +} + +sub _reload_cb_delete_symbol { + my $self = shift; + my %params = @_; + + my $sym = $params{symbol}; + my $mod = $params{module}; + my $file = $params{file}; + + # Make sure the changed file and the file that defined the sub are the same. + my $cb = $self->get_stage_callback('reload_remove_check') or return 0; + my $sub = $mod->can($sym) or return 0; + my $cobj = B::svref_2object($sub) or return 0; + my $subfile = $cobj->FILE or return 0; + + my $res = $cb->( + mod => $mod, + sym => $sym, + sub => $sub, + from_file => -f $subfile ? clean_path($subfile) : $subfile, + reload_file => -f $file ? clean_path($file) : $file, + ); + + # 0 means do not skip, so if the cb returned true we do not skip + return 0 if $res; + return 1; +} + +sub _monitor { + my $self = shift; + + if ($self->{+MONITORED} && $self->{+MONITORED}->[0] == $$) { + die "Monitor already starated\n" . "\n=======\n$0\n" . Carp::longmess() . "\n=====\n" . $self->{+MONITORED}->[1] . "\n" . $self->{+MONITORED}->[2] . "\n=======\n"; + } + + $self->{+MONITORED} = [$$, $0, Carp::longmess()]; + + my $reloader = $self->{+RELOADER}; + $reloader->reset(); + $reloader->refresh(); + + return $self->{+MONITORED}; +} + +sub check { + my $self = shift; + my ($state) = @_; + + return 1 if $self->{+CHANGED}; + + return 0 unless $self->{+MONITOR}; + + my $dtrace = $self->dtrace; + $dtrace->start if $self->{+RELOAD}; + + my $results = $self->{+RELOADER}->reload_changes(); + + $dtrace->stop if $self->{+RELOAD}; + + my (@todo, @fails); + for my $item (values %$results) { + my $stage = $self->{+STAGE} ? $self->{+STAGE}->name : 'default'; + $state->reload($stage => $item); + my $rel = $item->{reloaded}; + + next if $rel; # Reload success + + if (defined $rel) { # Not reloaded, but no error + push @todo => $item; + next; + } + } + + unless (@todo) { + $self->{+RELOADER}->refresh(); + return 0; + } + + $self->{+CHANGED} = 1; + $self->_notify("blacklisting changed files and reloading stage..."); + + my $bl = $self->_lock_blacklist(); + + my $dep_map = $self->dtrace->dep_map; + + my %CNI = reverse pairgrep { $b } %INC; + + my %seen; + while (@todo) { + my $item = shift @todo; + my $ref = ref($item); + + my ($mod, $abs, $rel); + if ($ref eq 'HASH') { + ($mod, $abs, $rel) = @{$item}{qw/module file relative/}; + } + elsif ($ref eq 'ARRAY') { + ($mod, $abs) = @$item; + $rel = $CNI{$abs} || $abs; + } + else { + die "Invalid ref type: $ref"; + } + + next if $seen{$abs}++; + next if $mod->can('TEST2_HARNESS_PRELOAD'); + $self->_notify("Blacklisting $mod..."); + print $bl "$mod\n"; + my $next = $dep_map->{$abs} or next; + push @todo => @$next; + } + + $self->_unlock_blacklist(); + + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader - Preload logic. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries before running tests. This +entire module is considered an "Implementation Detail". Please do not rely on +it always staying the same, or even existing in the future. Do not use this +directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/libold2/Test2/Harness/Runner/Preloader/Stage.pm b/libold2/Test2/Harness/Runner/Preloader/Stage.pm new file mode 100644 index 000000000..3559eabad --- /dev/null +++ b/libold2/Test2/Harness/Runner/Preloader/Stage.pm @@ -0,0 +1,62 @@ +package Test2::Harness::Runner::Preloader::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase qw{ <name eager }; + +sub category { $_[0]->{+CATEGORY} //= 'stage' } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader::Stage - Representation of a persistent stage process. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries for a specific stage before +running tests. This entire module is considered an "Implementation Detail". +Please do not rely on it always staying the same, or even existing in the +future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Reloader.pm b/libold2/Test2/Harness/Runner/Reloader.pm new file mode 100644 index 000000000..010a30727 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Reloader.pm @@ -0,0 +1,338 @@ +package Test2::Harness::Runner::Reloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/file2mod is_same_file/; + +use File::Spec(); + +BEGIN { + local $@; + my $inotify = eval { require Linux::Inotify2; 1 }; + if ($inotify) { + my $MASK = Linux::Inotify2::IN_MODIFY(); + $MASK |= Linux::Inotify2::IN_ATTRIB(); + $MASK |= Linux::Inotify2::IN_DELETE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + + *USE_INOTIFY = sub() { 1 }; + require constant; + constant->import(INOTIFY_MASK => $MASK); + } + else { + *USE_INOTIFY = sub() { 0 }; + *INOTIFY_MASK = sub() { 0 }; + } +} + +use Test2::Harness::Util::HashBase qw{ + <notify_cb <find_loaded_cb <should_watch_cb <can_reload_cb <reload_cb <delete_symbol_cb + <monitored <monitor_lookup + <watcher + <stat_min_gap <stat_last_checked + <pid +}; + +sub _pid_check { + my $self = shift; + + return 1 unless USE_INOTIFY; + + my $pid = $self->{+PID} //= $$; + + croak "PID has changed $$ vs $pid (Maybe you need to call reset()?)" + unless $$ == $pid; + + return 1; +} + +sub init { + my $self = shift; + $self->{+CAN_RELOAD_CB} //= $self->can('_can_reload'); + $self->{+FIND_LOADED_CB} //= $self->can('_find_loaded'); + $self->{+STAT_MIN_GAP} //= 2; + + $self->reset; +} + +sub reset { + my $self = shift; + delete $self->{+PID}; + $self->{+MONITORED} = {}; + $self->{+MONITOR_LOOKUP} = {}; + if (USE_INOTIFY) { + $self->{+WATCHER} = Linux::Inotify2->new; + $self->{+WATCHER}->blocking(0); + } else { + $self->{+WATCHER} = {}; + } + delete $self->{+STAT_LAST_CHECKED}; +} + +sub _find_loaded { keys %INC } + +sub refresh { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + my $cb = $self->{+FIND_LOADED_CB}; + for my $file ($self->$cb($monitored)) { + next if exists $monitored->{$file}; + $self->monitor($file); + } +} + +sub monitor { + my $self = shift; + my ($file) = @_; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + return if exists $monitored->{$file}; + + my $watch = $self->find_file_to_watch($file); + + return $monitored->{$file} = 0 unless $watch && -e $watch; + + if (my $should_watch_cb = $self->{+SHOULD_WATCH_CB}) { + return $monitored->{$file} = 0 unless $self->$should_watch_cb($file => $watch); + } + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($watch, INOTIFY_MASK()); + } + else { + my $stats = $self->{+WATCHER}; + $stats->{$watch} = $self->_get_file_times($watch); + } + + $self->{+MONITOR_LOOKUP}->{$watch} = $file; + $monitored->{$file} = $watch; + return $watch; +} + +sub find_file_to_watch { + my $self = shift; + my ($file) = @_; + + return $INC{$file} if $INC{$file} && -e $INC{$file}; + + for my $dir (@INC) { + next if ref($dir); + my $path = File::Spec->catfile($dir, $file); + return $path if -f $path; + } + + return $file if -e $file; +} + +sub _get_file_times { + my $self = shift; + my ($file) = @_; + my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); + return [$mtime, $ctime]; +} + +sub _get_changes { + my $self = shift; + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + my @todo = $inotify->read or return; + return {map { ($_->fullname() => 1) } @todo}; + } + + # Do not hammer the disk getting stat + my $check_time = time; + my $gap = $self->{+STAT_MIN_GAP}; + my $last_checked = $self->{+STAT_LAST_CHECKED}; + return if $last_checked && $gap && $gap > ($check_time - $last_checked); + $last_checked = $check_time; + + my $found = 0; + my $changed = {}; + my $stats = $self->{+WATCHER}; + for my $file (keys %$stats) { + my $old_times = $stats->{$file}; + my $new_times = $self->_get_file_times($file); + + # Compare times + next if $old_times->[0] == $new_times->[0] && $old_times->[1] == $new_times->[1]; + + # Update in case we choose not to reload + $stats->{$file} = $new_times; + + $found++; + $changed->{$file} = 1; + } + + return unless $found; + return $changed; +} + +sub _can_reload { + my %params = @_; + + my $mod = $params{module}; + + return 1 unless $mod->can('import'); + + return 0 if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return 0 if @{"$mod\::EXPORT"}; + return 0 if @{"$mod\::EXPORT_OK"}; + } + + return 1; +} + +sub reload_changes { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + $self->refresh(); + + my $changed = $self->_get_changes() or return; + + my $notify_cb = $self->{+NOTIFY_CB}; + + $notify_cb->(changes_detected => [keys %$changed]) if $notify_cb; + + my %out; + for my $file (sort keys %$changed) { + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($file, INOTIFY_MASK()); + } + + $notify_cb->(file_changed => $file) if $notify_cb; + + my $rel = $self->{+MONITOR_LOOKUP}->{$file}; + my $mod = file2mod($rel); + my %params = (reloader => $self, file => $file, relative => $rel, module => $mod, notify_cb => $notify_cb); + + my ($status, %fields) = $self->_reload_file(%params); + + $out{$file} = { + file => $file, + relative => $rel, + module => $mod, + reloaded => $status, + %fields, + }; + } + + return \%out; +} + +sub _reload_file { + my $self = shift; + my %params = @_; + + if (my $reload_cb = $self->{+RELOAD_CB}) { + my ($status, %fields) = $reload_cb->(%params); + return ($status, %fields) if defined $status; + } + + if (my $can_reload_cb = $self->{+CAN_RELOAD_CB}) { + my ($can, %fields) = $can_reload_cb->(%params); + return ($can, %fields) unless $can; + } + + my $notify_cb = delete $params{notify_cb}; + $notify_cb->(reload_inplace => \%params) if $notify_cb; + + my $del_cb = $self->{+DELETE_SYMBOL_CB}; + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my @warnings; + my $ok = eval { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + + my $stash = do { no strict 'refs'; \%{"${mod}\::"} }; + for my $sym (keys %$stash) { + next if $sym =~ m/::$/; + + next if $del_cb && $del_cb->(%params, symbol => $sym, stash => $stash); + + delete $stash->{$sym}; + } + + delete $INC{$rel}; + local $.; + require $rel; + die "Reloading '$rel' loaded '$INC{$rel}' instead of '$file', \@INC must have been altered" + unless is_same_file($file, $INC{$rel}); + + 1; + }; + my $err = $@; + + return (1) if $ok && !@warnings; + + $notify_cb->(reload_fail => {%params, warnings => \@warnings, error => $err}) if $notify_cb; + + return (undef, error => $err, warnings => \@warnings); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Reloader - reload logic. + +=head1 DESCRIPTION + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/libold2/Test2/Harness/Runner/Resource.pm b/libold2/Test2/Harness/Runner/Resource.pm new file mode 100644 index 000000000..81455162a --- /dev/null +++ b/libold2/Test2/Harness/Runner/Resource.pm @@ -0,0 +1,597 @@ +package Test2::Harness::Runner::Resource; +use strict; +use warnings; + +use Term::Table; +use Time::HiRes qw/time/; +use Test2::Util::Times qw/render_duration/; + +our $VERSION = '1.000152'; + +sub scope_global { 0 } +sub scope_host { 0 } +sub scope_run { 1 } + +sub setup {} + +sub new { + my $class = shift; + return bless({@_}, $class); +} + +sub tick { } + +sub refresh { } + +sub discharge { } + +sub sort_weight { + my $class = shift; + return 100 if $class->job_limiter; + return 50; +} + +sub job_limiter { 0 } + +sub job_limiter_max { } + +sub job_limiter_at_max { 0 } + +sub available { -1 } + +sub record { } + +sub assign { } + +sub release { } + +sub cleanup { } + +sub status_data {()} + +sub status_lines { + my $self = shift; + + my $data = $self->status_data || return; + return unless @$data; + + my $out = ""; + + for my $group (@$data) { + my $gout = "\n"; + $gout .= "**** $group->{title} ****\n\n" if defined $group->{title}; + + for my $table (@{$group->{tables} || []}) { + my $rows = $table->{rows}; + + if (my $format = $table->{format}) { + my $rows2 = []; + + for my $row (@$rows) { + my $row2 = []; + for (my $i = 0; $i < @$row; $i++) { + my $val = $row->[$i]; + my $fmt = $format->[$i]; + + $val = defined($val) ? render_duration($val) : '--' + if $fmt && $fmt eq 'duration'; + + push @$row2 => $val; + } + push @$rows2 => $row2; + } + + $rows = $rows2; + } + + next unless $rows && @$rows; + + my $tt = Term::Table->new( + header => $table->{header}, + rows => $rows, + + sanitize => 1, + collapse => 1, + auto_columns => 1, + + %{$table->{term_table_opts} || {}}, + ); + + $gout .= "** $table->{title} **\n" if defined $table->{title}; + $gout .= "$_\n" for $tt->render; + $gout .= "\n"; + } + + if ($group->{lines} && @{$group->{lines}}) { + $gout .= "$_\n" for @{$group->{lines}}; + $gout .= "\n"; + } + + $out .= $gout; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource - Base class for resource management classes + +=head1 DESCRIPTION + +Sometimes you have limited resources that must be shared/divided between tests +that run concurrently. Resource classes give you a way to leverage the IPC +system used by L<Test2::Harness> to manage resource assignment and recovery. + +=head1 SYNOPSIS + +Here is a resource class that simply assigns an integer to each test. It would +be possible to re-use integers, but since there are infinite integers this +example is kept simple and just always grabs the next one. + + package Test2::Harness::Runner::Resource::Foo; + use strict; + use warnings; + + use parent 'Test2::Harness::Runner::Resource'; + + sub setup { + my $class = shift; # NOT AN INSTANCE + ... + } + + sub available { + my $self = shift; + my ($task) = @_; + + # There are an infinite amount of integers, so we always return true + return 1; + } + + sub assign { + my $self = shift; + my ($task, $state) = @_; + + # Next ID, do not record the state change yet! + my $id = 1 + ($self->{ID} //= 0); + + print "ASSIGN: $id = $task->{job_id}\n"; + + # 'record' should get whatever we need to record the resource, whatever you + # pass in will become the argument to the record() sub below. This may be a + # scalar, a hash, an array, etc. It will be serialized to JSON before + # record() sees it. + $state->{record} = $id; + + # Pass the resource into the test, this can be done as envronment variables + # and/or arguments to the test (@ARGV). + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + + # The return is ignored. + return; + } + + sub record { + my $self = shift; + my ($job_id, $record_arg_from_assign) = @_; + + # The ID from $state->{record}->{$pkg} in assign. + my $id = $record_arg_from_assign; + + # Update our internal state to reflect the new ID. + $self->{ID} = $id; + + # Add a mapping of what job ID gets what integer ID. + $self->{ID_TO_JOB_ID}->{$id} = $job_id; + $self->{JOB_ID_TO_ID}->{$job_id} = $id; + + print "RECORD: $id = $job_id\n"; + + # The return is ignored + } + + sub tick { + my $self = shift; + + # This is called by only 1 process at a time and gives you a way to do + # extra stuff at a regular interval without other processes trying to + # do the same work at the same time. + # For example, if a database is left in a dirty state after it is + # released, you can fire off a cleanup action here knowing no other + # process will run it at the same time. You can also be sure no record + # messages will be sent while this sub is running as the process it + # runs in has a lock. + + ... + } + + + sub release { + my $self = shift; + my ($job_id) = @_; + + # Clear the internal mapping, the integer ID is now free. Theoretically it + # can be reused, but this example is not that complex. + my $id = delete $self->{JOB_ID_TO_ID}->{$job_id}; + + # This is called for all tests that complete, even if they did not use + # this resource, so we return if the job_id is not applicable. + return unless defined $id; + + delete $self->{ID_TO_JOB_ID}->{$id}; + + print " FREE: $id = $job_id\n"; + + # The return is ignored + } + + sub cleanup { + my $self = shift; + + print "CLEANUP!\n"; + } + + 1; + +The print statements generated will look like this when running 2 tests concurrently: + + yath test -R Foo -j2 t/testA.t t/testB.t + [...] + (INTERNAL) ASSIGN: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) RECORD: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) ASSIGN: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) RECORD: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) FREE: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) FREE: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) CLEANUP! + [...] + +Depending on the tests run the 'FREE' prints may be out of order. + +=head1 WORKFLOW + +=head2 HOW STATE IS MANAGED + +Depending on your preload configuration, yath may have several runners +launching tests. If a runner has nothing to do it will lock the queue and try +to find the next test that should be run. Only 1 of the runners will be in +control of the queue at any given time, but the control of the queue may pass +between runners. To manage this there is a mechanism to record messages that +allow each runner to maintain a copy of the current state. + +=head2 CHECK IF RESOURCES ARE AVAILABLE + +Each runner will have an instance of your resource class. When the runner is in +control of the queue, and wants to designate the next test to run, it will +check with the resource classes to make sure the correct resources are +available. To do that it will call C<available($task)> on each resource +instance. + +The C<$task> will contain the specification for the test, it is a hashref, and +you B<SHOULD NOT> modify it. The only key most people care about is the 'file' +key, which has the test file that will be run if resources are available. + +If resources are available, or if the specific file does not need the resource, +the C<available()> method should return true. If the file does need your +resource(s), and none are available, this should return false. If any resource +class returns false it means the test cannot be run yet and the runner will +look for another test to run. + +=head2 ASSIGN A RESOURCE + +If the runner has determined the test can be run, and all necessary resources +are available, it will then call C<assign($task, $state)> on all resource class +instances. At this time the resource class should decide what resource(s) to +assign to the class. + +B<CRITICAL NOTE:> the C<assing()> method B<MUST NOT> alter any internal state +on the resource class instance. State modification must wait for the +C<record()> method to be called. This is because the C<assign()> method is only +called in one runner process, the C<record()> method call will happen in every +runner process to insure they all have the same internal state. + +The assign() sub should modify the C<$state> hash, which has 3 keys: + +=over 4 + +=item env_vars => {} + +Env vars to set for the test + +=item args => [] + +Arguments to pass to the test + +=item record => ... + +Data needed to record the state change for resource classes. Can be a scalar, +hashref, arrayref, etc. It will be serialized to JSON to be passed between +processes. + +=back + +=head2 RECORD A RESOURCE + +Once a resource is assigned, a message will be sent to all runner processes +B<INCLUDING THE ONE THAT DID THE ASSIGN> that says it should call +C<record($job_id, $record_val)> on your resource class instance. Your resource +class instance must use this to update the state so that once done ALL +processes will have the proper internal state. + +The C<$record_val> is whatever you put into C<< $state->{record} >> in the +C<assign()> method above. + +=head2 QUEUE MANAGEMENT IS UNLOCKED + +Once the above has been done, queue management will be unlocked. You can be +guarenteed that only one process will be run the C<available()>, and +C<assign()> sequence at a time, and that they will be called in order, though +C<assign()> may not be called if another resource was not available. If +C<assign()> is called, you can be guarenteed that all processes, including the +one that called C<assign()> will have their C<record()> called with the proper +argument B<BEFORE> they try to manage the queue (which is the only place +resources are checked or assigned). + +=head2 RELEASE A RESOURCE + +Whenever a process that is using a resource exits, the runner that waits on +that process will I<eventually> send an IPC message announcing that the job_id +has completed. Every time a job_id completes the C<release($job_id)> method +will be called on your resource class in all runner processes. This allows the +state to be updated to reflect the freed resource. + +You can be guarenteed that any process that locks the queue to run a new +test will eventually see the message. The message may come in during a loop +that is checking for resources, in which case the state will not reflect the +resource being available, however in such cases the loop will end and be +called again later with the message having been receieved. There will be no +deadlock due to a queue manager waiting for the message. + +There are no guarentees about what order resources will be released in. + +=head1 METHODS + +=over 4 + +=item $class->setup($settings) + +This will be called once before the runner forks or initialized per-process +instances. If you have any "setup once" tasks to initialize resources before +tests run this is a good place to do it. + +This runs immedietly after plugin setup() methods are called. + +B<NOTE:> Do not rely on recording any global state here, the runner and +per-process instances may not be forked from the process that calls setup(). + +=item $res = $class->new(settings => $settings); + +A default new method, returns a blessed hashref with the settings key set to +the L<Test2::Harness::Settings> instance. + +=item $val = $res->available(\%task) + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +B<DO NOT MODIFY THE TASK HASHREF> + +Returns a positive true value if the resource is available. + +Returns false if the resource is not available, but will be in the future (IE +in use by another test, but will be free when that test is done). + +Returns a negative value if the resource is not available and never will be. +This will cause any tests dependent on the resource to be skipped. + +The only key in C<\%task> hashref that most resources will care about is the +C<'file'> key, which contains the test file to be run. + +=item $res->assign(\%task, \%state) + +B<DO NOT MODIFY THE TASK HASHREF> + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +If the task does not need any resources you may simply return. + +If resources are needed you should deduce what resources to assign. + +You should put any data needed to update the internal state of your resource +instance in the C<< $state->{record} >> hash key. It B<WILL> be serialized to +JSON before being used as an argument to C<record()>. + + $state->{record} = $id; + +If you do not set the 'record' key, or set it to undef, then the C<record()> +method will not be called. + +If your tests need to know what resources to use, you may set environment +variables and/or command line arguments to pass into the test (C<@ARGV>). + + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + +The C<\%state> hashref is used only by your instance, you are free to fully +replace the 'env_vars' and 'args' keys. They will eventually be merged into a +master state along with those of other resources, but this ref is exclusive to +you in this method. + +=item $inst->record($job_id, $record_arg_from_assign) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called in all processes so that your instance can update any +internal state. + +The C<$job_id> variable contains the id for the job to which the resource was +assigned. You should use this to record any internal state. The $job_id will be +passed to C<release()> when the job completes and no longer needs the resource. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example creating a database should not be +done here, multiple processes will fight to do the create. The creation, if +necessary should be done in C<assign()> which will be called in only one +process. + +=item $inst->release($job_id) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called for every test job that completes, even if it did not use +this resource. If the job_id did not use the resource you may simply return, +otherwise update the internal state to reflect that the resource is no longer +in use. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example deleting a database should not be +done here, multiple processes will fight to do the delete. C<assign()> is the +only method that will be run in a single process, so if a database needs to be +cleaned before it can be used you should clean it there. Any final cleanup +should be done in C<cleanup()> which will only be called by one process at the +very end. + +=item $inst->cleanup() + +This will be called once by the parent runner process just before it exits. +This is your chance to do any final cleanup tasks such as deleting databases +that are no longer going to be used by tests as no more will be run. + +=item $inst->tick() + +This is called by only 1 process at a time and gives you a way to do extra +stuff at a regular interval without other processes trying to do the same work +at the same time. + +For example, if a database is left in a dirty state after it is released, you +can fire off a cleanup action here knowing no other process will run it at the +same time. You can also be sure no record messages will be sent while this sub +is running as the process it runs in has a lock. + +=item $inst->refresh() + +Called once before each resource-request loop. This is your chance to do things +between each set of requests for resources. + +=item $bool = $inst->job_limiter() + +True if your resource is intended as a job limiter (IE alternative to +specifying -jN at the command line). + +=item $int = $inst->job_limiter_max() + +Max number of jobs this will allow at the moment, if this resource is a job +limiter. + +=item $bool = $inst->job_limiter_at_max() + +True if the limiter has reached its maximum number of running jobs. This is +used to avoid a resource-allocation loop as an optimization. + +=item $number = $inst->sort_weight() + +Used to sort resources if you want them to be checked in a specific order. For +most resources this defaults to 50. For job_limiter resources this defaults to +100. Lower numbers are sorted to the front of the list, IE they are aquired +first, before other resources. + +Job slots are sorted later (100) so that we do not try to grab a job slot if +other resources are not available. + +Most of the time order will not matter, however with Shared job slots we have a +race with other test runs to get slots, and checking availability is enough to +consume a slot, even if other resources are not available. + +=item $string = $inst->status_lines() + +Get a (multi-line) string with status info for this resource. This is used to +populate the output for the C<yath resources> command. + +The default implementation will build a string from the data provided by the +C<status_data()> method. + +=item $arrayref = $inst->status_data() + +The default implementation returns an empty list. + +This should return status data that looks like this: + + return [ + { + title => "Resource Group Title", + tables => [ + { + header => \@columns, + rows => [ + \@row1, + \@row2, + ], + + # Optional fields + ################## + + # formatting for fields in rows + format => [undef, undef, 'duration', ...], + + # Title for the table + title => "Table Title", + + # Options to pass to Term::Table if/when it the data is used in Term::Table + term_table_opts => {...}, + }, + + # Any number of tables is ok + {...}, + ], + }, + + # Any number of groups is ok + {...}, + ]; + +Currently the only supported formats are 'default' (undef), and 'duration'. +Duration takes a stamp and tells you how much time has passed since the stamp. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Resource/JobCount.pm b/libold2/Test2/Harness/Runner/Resource/JobCount.pm new file mode 100644 index 000000000..1c8fb3f6d --- /dev/null +++ b/libold2/Test2/Harness/Runner/Resource/JobCount.pm @@ -0,0 +1,168 @@ +package Test2::Harness::Runner::Resource::JobCount; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw/<settings <job_count <used <free/; +use Time::HiRes qw/time/; +use List::Util qw/min/; + +sub job_limiter { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + $self->{+JOB_COUNT} //= $settings ? $settings->runner->job_count // 1 : 1; + $self->{+USED} //= {}; + $self->{+FREE} //= [1 .. $self->{+JOB_COUNT}]; +} + +sub job_limiter_max { + my $self = shift; + return $self->{+JOB_COUNT}; +} + +sub job_limiter_at_max { + my $self = shift; + return 0 if @{$self->{+FREE}}; + return 1; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + return -1 if $self->{+JOB_COUNT} < $tmin; + return -1 if $rmin < $tmin; + + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + return 1 if @{$self->{+FREE}} >= $concurrency; + return 0; +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + $state->{record} = { + count => $concurrency, + file => $task->{rel_file}, + stamp => time, + }; + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $concurrency; +} + +sub record { + my $self = shift; + my ($job_id, $info) = @_; + + my $count = $info->{count}; + my @use = splice @{$self->{+FREE}}, 0, $count; + $info->{slots} = \@use; + + $self->{+USED}->{$job_id} = $info; +} + +sub release { + my $self = shift; + my ($job_id) = @_; + + # Could be a free with no used slot. + my $info = delete $self->{+USED}->{$job_id} or return; + my $slots = $info->{slots}; + + push @{$self->{+FREE}} => @$slots; +} + +sub status_data { + my $self = shift; + + my @rows; + + my $time = time; + + for my $info (sort { $a->{stamp} <=> $b->{stamp} } values %{$self->{+USED}}) { + my $count = @{$info->{slots} || []}; + push @rows => [$time - $info->{stamp}, $count, $info->{file}]; + } + + push @rows => [undef, scalar(@{$self->{+FREE}}), '** FREE **']; + + return [ + { + tables => [ + { + headers => [qw/Runtime Slots Name/], + format => ['duration'], + rows => \@rows, + }, + ], + }, + ], +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::JobCount - limit the job count (-j) + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Resource/SharedJobSlots.pm b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots.pm new file mode 100644 index 000000000..7651f90f2 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots.pm @@ -0,0 +1,439 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Test2::Harness::Runner::Resource::SharedJobSlots::State; +use Test2::Harness::Runner::Resource::SharedJobSlots::Config; + +use Time::HiRes qw/time/; +use List::Util qw/min/; +use Carp qw/confess/; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw{ + <settings + <state + <config + <runner_id + <runner_pid + <job_limiter_max + <observe +}; + +sub job_limiter { 1 } + +sub scope_host { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + die "Could not find shared jobs config.\n" + unless $sconf; + + my $access_id = $self->{+RUNNER_ID} //= $settings->runner->runner_id if $settings->check_prefix('runner'); + my $access_pid = $self->{+RUNNER_PID} //= $Test2::Harness::Runner::RUNNER_PID // $App::Yath::Command::runner::RUNNER_PID; + + my $prefix = $settings->debug->procname_prefix // ''; + my $name = $settings->harness->project // ''; + + my $dir; + if (my $path = $settings->harness->config_file) { + if ($path =~ m{^(.*)/[^/]+$}) { + $dir = $1; + } + } + + $dir //= $settings->harness->cwd; + + unless ($name) { + $name = $dir; + $name =~ s{^.*/}{}; + } + + $name = "$prefix-$name" if $prefix; + + $self->{+JOB_LIMITER_MAX} = min(grep { $_ } $sconf->max_slots_per_run, $settings->runner->job_count); + + $self->{+STATE} = Test2::Harness::Runner::Resource::SharedJobSlots::State->new( + state_umask => $sconf->state_umask, + state_file => $sconf->state_file, + access_id => $access_id, + access_pid => $access_pid, + access_meta => { + dir => $dir, + name => $name, + runner_id => $access_id, + runner_pid => $access_pid, + }, + + algorithm => $sconf->algorithm, + max_slots => $sconf->max_slots, + max_slots_per_job => $sconf->max_slots_per_job, + max_slots_per_run => $sconf->max_slots_per_run, + min_slots_per_run => $sconf->min_slots_per_run, + default_slots_per_run => $sconf->default_slots_per_run, + default_slots_per_job => $sconf->default_slots_per_job, + + my_max_slots => min($self->settings->runner->job_count, $sconf->max_slots), + my_max_slots_per_job => min($self->settings->runner->slots_per_job, $sconf->max_slots_per_job), + ); + + $self->{+CONFIG} = $sconf; + + return; +} + +# Disable this short-circuit otherwise we may never queue a request! +sub job_limiter_at_max { 0 } + +sub refresh { $_[0]->{+STATE}->update_registration } + +sub _job_concurrency { + my $self = shift; + my ($task) = @_; + + my $rmax = $self->settings->runner->job_count; + my $jmax = $self->settings->runner->slots_per_job; + my $srmax = $self->{+CONFIG}->max_slots_per_run; + my $sjmax = $self->{+CONFIG}->max_slots_per_job; + + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + my $max = min($tmax, $sjmax, $srmax, $jmax, $rmax); + + # Invalid condition, minimum is more than our maximim + return if $tmin > $max; + $max = $tmin if $max < $tmin; + + return [$tmin, $max]; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $con = $self->_job_concurrency($task); + return -1 unless $con; + + my $granted = $self->{+STATE}->allocate_slots(con => $con, job_id => $task->{job_id}); + + return unless $granted; + + return $granted +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + return if $self->{+OBSERVE}; + + my $info = $self->{+STATE}->assign_slots( + job => { + job_id => $task->{job_id}, + file => $task->{rel_file} // $task->{file} // $task->{job_name}, + }, + ); + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $info->{count}; + + return $info; +} + +sub record { } # NOOP + +sub release { + my $self = shift; + my ($job_id) = @_; + + return if $self->{+OBSERVE}; + + $self->{+STATE}->release_slots(job_id => $job_id); + + return; +} + +sub status_data { + my $self = shift; + + my @groups; + + my $state = $self->state->state; + my $runners = $state->{runners}; + my $access = $state->{access}; + + my $global_status = { + todo => 0, + allotted => 0, + assigned => 0, + pending => 0, + }; + + my $time = time; + + for my $runner (sort { $a->{added} <=> $b->{added} } values %$runners) { + my $run_status = { + todo => $runner->{todo}, + allotted => $runner->{allotment}, + assigned => 0, + pending => 0, + }; + + my $job_table = { + header => [qw/Runtime Slots Name/], + format => ['duration', undef, undef], + rows => [], + }; + + for my $job (sort { $a->{started} <=> $b->{started} } values %{$runner->{assigned}}) { + $run_status->{assigned} += $job->{count}; + my $stamp = $job->{started}; + my $slots = $job->{count}; + + push @{$job_table->{rows}} => [$time - $stamp, $slots, $job->{file} // $job->{job_id}]; + } + + $run_status->{pending} = $runner->{allotment} - $run_status->{assigned}; + + $global_status->{$_} += $run_status->{$_} for keys %$global_status; + + my $run_table = { + header => [qw/Todo Allotted Assigned Pending/], + rows => [[$run_status->{todo}, $run_status->{allotted}, $run_status->{assigned}, $run_status->{pending}]], + }; + + my $acc = $access->{$runner->{runner_id}}; + push @groups => { + title => "$acc->{user} - $acc->{name} - $acc->{access_id}", + tables => [ + $run_table, + $job_table, + ], + }; + } + + $global_status->{total} = $self->state->{max_slots}; + $global_status->{free} = $global_status->{total} - ($global_status->{assigned} + $global_status->{pending}); + $global_status->{free} = "$global_status->{free} (Minimum per-run overrides max slot count in some cases)" if $global_status->{free} < 0; + + unshift @groups => { + title => 'System Wide Summary', + tables => [ + { + header => ['Todo', 'Total Shared Slots', 'Allotted Shared Slots', 'Assigned Shared Slots', 'Pending Shared Slots', 'Free Shared Slots'], + rows => [[ @{$global_status}{qw/todo total allotted assigned pending free/} ]], + } + ], + }; + + return \@groups; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots - limit the job count (-j) per machine + +=head1 SYNOPSIS + +B<This synopsis is not about using this in code, but rather how to use it on the command line.> + +In order to use SharedJobSlots you must ether create the C<.sharedjobslots.yml> +file, or provide the C<--shared-jobs-config PATH> argument on the command line. +The C<PATH> must be a path to a yaml file with configuration specifications for +job sharing. + +=head1 CONFIG FILE + +Config files for shared slots must be yaml file, they must also be parsable by +L<YAML::Tiny>, which implements a subset of yaml. + +Here is an example config file: + + --- + DEFAULT: + state_file: /tmp/yath-slot-state + max_slots: 8 + max_slots_per_job: 2 + max_slots_per_run: 6 + + myhostname: + state_file: /tmp/myhostname-slot-state + max_slots: 16 + max_slots_per_job: 4 + max_slots_per_run: 12 + +=head2 TOP LEVEL KEYS (HOSTNAMES) + +All top level keys are hostnames. When the config is read the settings for the +current hostname will be used. If the hostname is not defined then the +C<DEFAULT> host will be read. If there is no C<DEFAULT> host defined an +exception will be thrown. + +=head2 CONFIG OPTIONS + +Each option must be specified under a hostname, none of these are valid on +their own. + +=over 4 + +=item state_file: /path/to/shared/state/file + +B<REQUIRED> + +This specifies the path to the shared state file. All yath processes by all +users who are sharing slots need read+write access to this file. + +=item state_umask: 0007 + +Defaults to C<0007>. Used to set the umask of the state file as well as the +lock file. + +=item max_slots: 8 + +Max slots system-wide for all users to share. + +=item max_slots_per_run: 4 + +Max slots a specific test run can use. + +=item min_slots_per_run: 0 + +Minimum slots per run. + +Set this if you want to make sure that all runs get at least N slots, +B<EVEN IF IT MEANS GOING OVER THE SYSTEM-WIDE MAXIMUM!>. + +This defaults to 0. + +=item max_slots_per_job: 2 + +Max slots a specific test job (test file) can use. + +=item default_slots_per_run: 4 + +If the user does not specify a number of slots, use this as the default. + +=item default_slots_per_job: 2 + +If the user does not specify a number of job slots, use this as the default. + +=item algorithm: fair + +=item algorithm: first + +=item algorithm: Fully::Qualified::Module::function_name + +Algorithm to use when assigning slots. 'fair' is the default. + +=back + +=head3 ALGORITHMS + +These are algorithms that are used to decide which test runs get which slots. + +=over 4 + +=item fair + +B<DEFAULT> + +This algorithm tries to balance slots so that all runs share an equal fraction +of available slots. If there are not enough slots to go around then priority +goes to oldest runs, followed by oldest requests. + +=item first + +Priority goes to the oldest run, followed by the next oldest, etc. If the run +age is not sufficient to sort requests this will fall back to 'fair'. + +This is mainly useful for CI systems or batched test boxes. This will give +priority to the first test run started, so additional test runs will not +consume slots the first run wants to use, but if the first run is winding down +and does not need all the slots, the second test run can start using only the +spare slots. + +Use this with ordered test runs where you do not want a purely serial run +order. + +=item Fully::Qualified::Module::function_name + +You can specify custom algorithms by giving fully qualified subroutine names. + +=back + +Example custom algorithm: + + sub custom_sort { + my ($state_object, $state_data, $a, $b) = @_; + + return 1 if a_should_come_first($a, $b); + return -1 if b_should_come_first($a, $b); + return 0 if both_have_same_priority($a, $b); + + # *shrug* + return 0; + } + +Ultimately this is used in a C<sort()> call, usual rules apply, return should +be 1, 0, or -1. $a and $b are the 2 items being compared. $state_object is an +instance of C<Test2::Harness::Runner::Resource::SharedJobSlots::State>. +$state_data is a hashref like you get from C<< $state_object->state() >> which +is useful if you want to know how many slots each runner is using for a 'fair' +style algorth. + +Take a look at the C<request_sort_XXX> methods on +C<Test2::Harness::Runner::Resource::SharedJobSlots::State> which implement the +3 original sorting methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm new file mode 100644 index 000000000..353c6761c --- /dev/null +++ b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm @@ -0,0 +1,178 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::Config; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Sys::Hostname qw/hostname/; +use App::Yath::Util qw/find_in_updir/; + +use Test2::Harness::Util::HashBase qw{ + <config_file + <config_raw + + <host + + <common_conf + <host_conf + + +state_file + +state_umask + +algorithm + +max_slots + +max_slots_per_job + +max_slots_per_run + +min_slots_per_run + +default_slots_per_job + +default_slots_per_run +}; + +sub find { + my $class = shift; + my (%opts) = @_; + + my $base_name = delete $opts{base_name}; + my $settings = delete $opts{settings}; + my $config_file = delete $opts{config_file}; + + unless ($config_file) { + $base_name //= ($settings && $settings->check_prefix('runner')) ? $settings->runner->shared_jobs_config : '.sharedjobslots.yml'; + $config_file = ($base_name =~ m{(/|\\)} || -e $base_name) ? $base_name : find_in_updir($base_name); + } + + return unless $config_file && -e $config_file; + + return $class->new(%opts, config_file => $config_file); +} + +sub init { + my $self = shift; + + my $config_file = $self->{+CONFIG_FILE}; + + my $config = YAML::Tiny->read($config_file) or die "Could not read '$config_file'"; + $config = $self->{+CONFIG_RAW} = $config->[0]; # First doc only + + my $host = $self->{+HOST} //= hostname(); + + # Normalize an empty host config section to a hashref + $config->{$host} ||= {} if exists $config->{$host}; + + unless ($self->{+HOST_CONF} = $config->{$host}) { + if ($self->{+HOST_CONF} = $config->{DEFAULT}) { + $self->{+HOST} = 'DEFAULT'; + } + else { + die "Could not find '$host' or 'DEFAULT' settings in '$config_file'.\n"; + } + + warn <<" EOT" unless $self->{+HOST_CONF}->{no_warning}; +Using the 'DEFAULT' shared-slots host config. +You may want to add the current host to the config file. +To silence this warning, set the 'no_warning' key to true in the DEFAULT host config. + Config File: $config_file +Current Host: $host + EOT + } + + if ($self->{+HOST_CONF}->{use_common} //= 1) { + $self->{+COMMON_CONF} = $config->{'COMMON'} // {}; + } + + $self->{+COMMON_CONF} //= {}; + + #sanity check + $self->max_slots; + + return; +} + +sub state_umask { $_[0]->{+STATE_UMASK} //= $_[0]->_get_config_option(+STATE_UMASK, default => 0007) } +sub state_file { $_[0]->{+STATE_FILE} //= $_[0]->_get_config_option(+STATE_FILE, require => 1) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_get_config_option(+MAX_SLOTS, required => 1) } +sub min_slots_per_run { $_[0]->{+MIN_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MIN_SLOTS_PER_RUN, default => 0) } +sub max_slots_per_job { $_[0]->{+MAX_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_JOB, default => $_[0]->max_slots) } +sub max_slots_per_run { $_[0]->{+MAX_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_RUN, default => $_[0]->max_slots) } +sub default_slots_per_job { $_[0]->{+DEFAULT_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_JOB, default => $_[0]->max_slots_per_job) } +sub default_slots_per_run { $_[0]->{+DEFAULT_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_RUN, default => $_[0]->max_slots_per_run) } + +sub _get_config_option { + my $self = shift; + my ($field, %opts) = @_; + + my $val = $self->{+HOST_CONF}->{$field} // $self->{+COMMON_CONF}->{$field} // $opts{default}; + + die "'$field' not set in '$self->{+CONFIG_FILE}' for host '$self->{+HOST}' or under 'COMMON' config.\n" + if $opts{required} && !defined($val); + + return $val; +} + +sub algorithm { + my $self = shift; + + return $self->{+ALGORITHM} if $self->{+ALGORITHM}; + + my $algorithm = $self->_get_config_option(+ALGORITHM, default => 'fair'); + + if ($algorithm =~ m/^(.*)::([^:]+)$/) { + my ($mod, $sub) = ($1, $2); + require(mod2file($mod)); + } + else { + require Test2::Harness::Runner::Resource::SharedJobSlots::State; + + my $short = $algorithm; + $algorithm = "_redistribute_$algorithm"; + + die "'$short' is not a valid algorithm (in file '$self->{+CONFIG_FILE}' under host '$self->{+HOST}' key 'algorithm'). Must be 'fair', 'first', or a Fully::Qualified::Module::function_name." + unless Test2::Harness::Runner::Resource::SharedJobSlots::State->can($algorithm); + } + + return $self->{+ALGORITHM} = $algorithm; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::Config - Config for shared job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm new file mode 100644 index 000000000..86646242f --- /dev/null +++ b/libold2/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm @@ -0,0 +1,384 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/time/; +use List::Util qw/min sum0 max/; +use Carp qw/croak/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase qw{ + <max_slots + <max_slots_per_job + <max_slots_per_run + <min_slots_per_run + <default_slots_per_job + <default_slots_per_run + + <my_max_slots + <my_max_slots_per_job + + <algorithm + + <ready_assignments +}; + +use constant RUNNERS => 'runners'; +use constant RUNNER_ID => 'access_id'; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'max_slots' is a required attribute" unless $self->{+MAX_SLOTS}; + croak "'max_slots_per_job' is a required attribute" unless $self->{+MAX_SLOTS_PER_JOB}; + croak "'max_slots_per_run' is a required attribute" unless $self->{+MAX_SLOTS_PER_RUN}; + + $self->{+MY_MAX_SLOTS} //= $self->{+MAX_SLOTS}; + $self->{+MY_MAX_SLOTS_PER_JOB} //= $self->{+MAX_SLOTS_PER_JOB}; + + $self->{+MIN_SLOTS_PER_RUN} //= 0; + + $self->{+ACCESS_META}->{name} //= $self->{+ACCESS_ID}; + + $self->{+ALGORITHM} //= '_redistribute_fair'; +} + +sub init_state { + my $self = shift; + my $state = $self->SUPER::init_state(); + $state->{+RUNNERS} = {}; + return $state; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $removed = $self->SUPER::_clear_old_registrations(@_); + + my $runners = $state->{+RUNNERS}; + delete $runners->{$_} for @$removed; + + return $removed; +} + +sub allocate_slots { + my $self = shift; + my (%params) = @_; + + my $con = $params{con} or croak "'con' is required"; + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_allocate_slots', con => $con, job_id => $job_id); +} + +sub assign_slots { + my $self = shift; + my (%params) = @_; + + my $job = $params{job} or croak "'job' is required"; + + return $self->transaction(rw => '_assign_slots', job => $job); +} + +sub release_slots { + my $self = shift; + my (%params) = @_; + + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_release_slots', job_id => $job_id); +} + +sub _get_runner_entry { + my $self = shift; + my ($state, $runner_id) = @_; + + $runner_id //= $self->{+RUNNER_ID}; + + return $state->{+RUNNERS}->{$runner_id} //= { + runner_id => $runner_id, + added => time, + + todo => 0, + allocated => 0, + allotment => 0, + assigned => {}, + + max_slots => $self->{+MY_MAX_SLOTS}, + max_slots_per_job => $self->{+MY_MAX_SLOTS_PER_JOB}, + }; +} + +sub _allocate_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job_id = $params{job_id}; + my $con = $params{con}; + my ($min, $max) = @$con; + $self->_runner_todo($entry, $job_id => $max); + + my $allocated = $entry->{allocated} //= 0; + + # We have what we need already allocated + return $entry->{allocated} = $max + if $max <= $allocated; + + return $entry->{allocated} + if $entry->{allocated} >= $min; + + # Our allocation, if any, is not big enough, free it so we do not have a + # deadlock with all runner holding an insufficient allocation. + $allocated = $entry->{allocated} = 0; + + my $calcs = $self->_runner_calcs($entry); + + for (0 .. 1) { + $self->_redistribute($state) if $_; # Only run on second loop + + # Cannot do anything if we have no allotment or no available slots. + # This will go to the next loop for a redistribution, or end the loop. + my $allotment = $entry->{allotment} or next; + my $available = $allotment - $calcs->{assigned} or next; + + # If we get here we have an allotment (not 0) but it does not mean the + # minimum, so we have to skip the test. + return -1 if $allotment < $min; + + next unless $available >= $min; + + return $entry->{allocated} = min($available, $max); + } + + return 0; +} + +sub _assign_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job = $params{job}; + my $job_id = $job->{job_id}; + my $allocated = $entry->{allocated}; + + $self->_runner_todo($entry, $job_id => -1); + + $job->{count} = $allocated; + $job->{started} = time; + + $entry->{allocated} = 0; + + $entry->{assigned}->{$job->{job_id}} = $job; + + return $job; +} + +sub _release_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + + my $job_id = $params{job_id}; + + delete $entry->{assigned}->{$job_id}; + delete $entry->{_calc_cache}; + + $self->_runner_todo($entry, $job_id => -1); + + # Reduce our allotment if it makes sense to do so. + my $calcs = $self->_runner_calcs($entry); + $entry->{allotment} = $calcs->{total} if $entry->{allotment} > $calcs->{total}; +} + +sub _runner_todo { + my $sef = shift; + my ($entry, $job_id, $count) = @_; + + my $jobs = $entry->{jobs} //= {}; + + if ($count) { + if ($count < 0) { + $count = delete $jobs->{$job_id}; + } + else { + $jobs->{$job_id} = $count; + } + } + elsif ($job_id) { + $count = $jobs->{$job_id}; + } + + $entry->{todo} = sum0(values %$jobs); + + return $count; +} + +sub _runner_calcs { + my $self = shift; + my ($runner) = @_; + + return $runner->{_calc_cache} if $runner->{_calc_cache}; + + my $max = min(grep {$_} $self->{+MAX_SLOTS_PER_RUN}, $runner->{max_slots}); + my $assigned = sum0(map { $_->{count} } values %{$runner->{assigned} //= {}}); + my $active = $runner->{allocated} + $assigned; + my $total = $runner->{todo} + $active; + my $wants = ($total >= $max) ? max($max, $active) : max($total, $active); + + return $runner->{_calc_cache} = { + max => $max, + assigned => $assigned, + active => $active, + total => $total, + wants => $wants, + }; +} + +sub _redistribute { + my $self = shift; + my ($state) = @_; + + my $max_run = $self->{+MAX_SLOTS_PER_RUN}; + + my $wanted = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + $runner->{allotment} = $calcs->{wants}; + $wanted += $calcs->{wants}; + } + + # Everyone gets what they want! + my $max = $self->{+MAX_SLOTS}; + return if $wanted <= $max; + + my $meth = $self->{+ALGORITHM}; + + return $self->$meth($state); +} + +sub _redistribute_first { + my $self = shift; + my ($state) = @_; + + my $min = $self->{+MIN_SLOTS_PER_RUN}; + my $max = $self->{+MAX_SLOTS}; + + my $c = 0; + for my $runner (sort { $a->{added} <=> $b->{added} } values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + my $wants = $calcs->{wants}; + + if ($max >= $wants) { + $runner->{allotment} = $wants; + } + else { + $runner->{allotment} = max($max, $min, 0); + } + + $max -= $runner->{allotment}; + + $c++; + } + + return; +} + +sub _redistribute_fair { + my $self = shift; + my ($state) = @_; + + my $runs = scalar keys %{$state->{+RUNNERS}}; + + # Avoid a divide by 0 below. + return unless $runs; + + my $total = $self->{+MAX_SLOTS}; + my $min = $self->{+MIN_SLOTS_PER_RUN}; + + my $used = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + + # We never want less than the 'active' number + my $set = $calcs->{active}; + + # If min is greater than the active number and there are todo tests, we + # use the min instead. + $set = $min if $set < $min && $runner->{todo}; + + $runner->{allotment} = $set; + $used += $set; + } + + my $free = $total - $used; + return unless $free >= 1; + + # Is there a more efficient way to do this? Yikes! + my @runners = values %{$state->{+RUNNERS}}; + while ($free > 0) { + @runners = sort { $a->{allotment} <=> $b->{allotment} || $a->{added} <=> $b->{added} } + grep { my $c = $self->_runner_calcs($_); $c->{wants} > $_->{allotment} } + @runners; + + $free--; + $runners[0]->{allotment}++; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::State - shared state for job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Run.pm b/libold2/Test2/Harness/Runner/Run.pm new file mode 100644 index 000000000..f67ac8a1f --- /dev/null +++ b/libold2/Test2/Harness/Runner/Run.pm @@ -0,0 +1,130 @@ +package Test2::Harness::Runner::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use File::Spec(); + +use Test2::Harness::Util::File::JSONL; + +use parent 'Test2::Harness::Run'; +use Test2::Harness::Util::HashBase qw{ + <workdir + <state + <run_id + + +run_dir +}; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'workdir' is a required attribute" unless $self->{+WORKDIR}; + croak "'state' is a required attribute" unless $self->{+STATE}; + croak "'run_id' is a required attribute" unless $self->{+RUN_ID}; +} + +sub run_dir { $_[0]->{+RUN_DIR} //= $_[0]->SUPER::run_dir($_[0]->{+WORKDIR}) } + +sub jobs { + my $self = shift; + my $data = $self->state->data->queue->{$self->{+RUN_ID}} or return []; + return $data->{list}; +} + +sub add_job { + my $self = shift; + my ($job, $spawn_time) = @_; + + my $json_data = $job->TO_JSON(); + $json_data->{stamp} = $spawn_time; + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + my $jobs = $data->jobs->{$self->{+RUN_ID}} //= { + closed => 0, + list => [], + }; + + push @{$jobs->{list}} => $json_data, + }); + + return $json_data; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Run - Runner specific subclass of a test run. + +=head1 DESCRIPTION + +Runner subclass of L<Test2::Harness::Run> for use inside the runner. + +=head1 METHODS + +In addition to the methods provided by L<Test2::Harness::Run>, these are provided. + +=over 4 + +=item $dir = $run->workdir + +Runner directory. + +=item $dir = $run->run_dir + +Directory specific to this run. + +=item $path = $run->jobs_file + +Path to the C<jobs.jsonl> file. + +=item $fh = $run->jobs + +Filehandle to C<jobs.jsonl>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/Spawn.pm b/libold2/Test2/Harness/Runner/Spawn.pm new file mode 100644 index 000000000..5bb3b83f3 --- /dev/null +++ b/libold2/Test2/Harness/Runner/Spawn.pm @@ -0,0 +1,89 @@ +package Test2::Harness::Runner::Spawn; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Job'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + + $self->{+RUN} //= Test2::Harness::Runner::Spawn::Run->new(); +} + +sub out_file { sprintf('/proc/%i/fd/1', $_[0]->{+TASK}->{owner}) } +sub err_file { sprintf('/proc/%i/fd/2', $_[0]->{+TASK}->{owner}) } +sub in_file { undef } + +sub args { @{$_[0]->{+TASK}->{args} //= []} } + +sub job_dir { "" } +sub run_dir { "" } + +sub use_stream { 0 } +sub event_uuids { 0 } +sub mem_usage { 0 } +sub io_events { 0 } + +# These return lists +sub load_import { } +sub load { } + +package Test2::Harness::Runner::Spawn::Run; + +sub new { bless {}, shift }; + +sub env_vars { {} } + +sub AUTOLOAD { } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Spawn - Minimal job class used for spawning processes + +=head1 DESCRIPTION + +Do not use this directly... + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Runner/State.pm b/libold2/Test2/Harness/Runner/State.pm new file mode 100644 index 000000000..163a6685d --- /dev/null +++ b/libold2/Test2/Harness/Runner/State.pm @@ -0,0 +1,875 @@ +package Test2::Harness::Runner::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::State; + +use Test2::Harness::Settings; +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run; +use Test2::Harness::Util::Queue; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase( + # These are construction arguments + qw{ + <eager_stages + <state + <workdir + <preloader + <no_poll + <resources + job_count + +settings + }, + + qw{ + <dispatch_file + <queue_ended + + <pending_tasks <task_lookup + <pending_runs +run <stopped_runs + <pending_spawns + + <running + <running_categories + <running_durations + <running_conflicts + <running_tasks + + <stage_readiness + + <task_list + + <halted_runs + + <reload_state + + <observe + }, +); + +sub init { + my $self = shift; + + croak "You must specify a workdir or provide state" + unless $self->{+STATE} || defined $self->{+WORKDIR}; + + $self->{+WORKDIR} //= $self->{+STATE}->workdir; + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; + + if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { + my $settings = $self->settings; + my $resources = $self->{+RESOURCES} //= []; + for my $res (@{$self->settings->runner->resources}) { + require(mod2file($res)); + push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); + } + } + + unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { + require Test2::Harness::Runner::Resource::JobCount; + push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); + } + + @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; + + $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); + + $self->{+RELOAD_STATE} //= {}; + + $self->poll; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->state->settings; +} + +sub run { + my $self = shift; + return $self->{+RUN} if $self->{+RUN}; + $self->poll(); + return $self->{+RUN}; +} + +sub done { + my $self = shift; + + $self->poll(); + + return 0 if $self->{+RUNNING}; + return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; + + return 0 if $self->{+RUN}; + return 0 if @{$self->{+PENDING_RUNS} //= []}; + + return 0 unless $self->{+QUEUE_ENDED}; + + return 1; +} + +sub next_task { + my $self = shift; + my ($stage) = @_; + + $self->poll(); + $self->clear_finished_run(); + + while(1) { + if (@{$self->{+PENDING_SPAWNS} //= []}) { + my $spawn = shift @{$self->{+PENDING_SPAWNS}}; + next unless $spawn->{stage} eq $stage; + $self->start_spawn($spawn); + return $spawn; + } + + my $task = shift @{$self->{+TASK_LIST}} or return undef; + + # If we are replaying a state then the task may have already completed, + # so skip it if it is not in the running lookup. + next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; + next unless $task->{stage} eq $stage; + + return $task; + } +} + +sub advance { + my $self = shift; + $self->poll(); + + $_->tick() for @{$self->{+RESOURCES} //= []}; + + $self->advance_run(); + return 0 unless $self->{+RUN}; + return 1 if $self->advance_tasks(); + return $self->clear_finished_run(); +} + +my %ACTIONS = ( + queue_run => '_queue_run', + queue_task => '_queue_task', + queue_spawn => '_queue_spawn', + start_spawn => '_start_spawn', + start_run => '_start_run', + start_task => '_start_task', + stop_run => '_stop_run', + stop_task => '_stop_task', + retry_task => '_retry_task', + stage_ready => '_stage_ready', + stage_down => '_stage_down', + end_queue => '_end_queue', + halt_run => '_halt_run', + truncate => '_truncate', + reload => '_reload', +); + +sub poll { + my $self = shift; + + return if $self->{+NO_POLL}; + + my $queue = $self->dispatch_file; + + for my $item ($queue->poll) { + my $data = $item->[-1]; + my $item = $data->{item}; + my $action = $data->{action}; + my $pid = $data->{pid}; + + my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; + + $self->$sub($item, $pid); + } +} + +sub _enqueue { + my $self = shift; + my ($action, $item) = @_; + $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); + $self->poll; +} + +sub truncate { + my $self = shift; + $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; + $self->_enqueue(truncate => $$); + $self->poll; +} + +sub _truncate { } + +sub end_queue { $_[0]->_enqueue('end_queue' => 1) } +sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } + +sub halt_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(halt_run => $run_id); + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run_id}; + $data->jobs->{$run_id}->{closed} = 1; + }); +} + +sub _halt_run { + my $self = shift; + my ($run_id) = @_; + + delete $self->{+PENDING_TASKS}->{$run_id}; + + $self->{+HALTED_RUNS}->{$run_id}++; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + $self->_enqueue(queue_run => $run); +} + +sub _queue_run { + my $self = shift; + my ($run) = @_; + + push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( + %$run, + workdir => $self->{+WORKDIR}, + state => $self->{+STATE}, + ); + + return; +} + +sub start_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(start_run => $run_id); +} + +sub _start_run { + my $self = shift; + my ($run_id) = @_; + + my $run = shift @{$self->{+PENDING_RUNS}}; + die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; + die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; + + $self->{+RUN} = $run; + + return; +} + +sub stop_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(stop_run => $run_id); +} + +sub _stop_run { + my $self = shift; + my ($run_id) = @_; + + $self->{+STOPPED_RUNS}->{$run_id} = 1; + + return; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + $spawn->{spawn} //= 1; + $spawn->{id} //= gen_uuid(); + $self->_enqueue(queue_spawn => $spawn); +} + +sub _queue_spawn { + my $self = shift; + my ($spawn) = @_; + + $spawn->{id} //= gen_uuid(); + $spawn->{spawn} //= 1; + $spawn->{use_preload} //= 1; + + $spawn->{stage} //= 'default'; + $spawn->{stage} = $self->task_stage($spawn); + + push @{$self->{+PENDING_SPAWNS}} => $spawn; + + return; +} + +sub start_spawn { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_spawn => $spec); +} + +sub _start_spawn { + my $self = shift; + my ($spec) = @_; + + my $uuid = $spec->{id} or die "Could not find UUID for spawn"; + + @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; + + return; +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + $self->_enqueue(queue_task => $task); +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + my $job_id = $task->{job_id} or die "Task missing job_id"; + my $run_id = $task->{run_id} or die "Task missing run_id"; + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + +sub start_task { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_task => $spec); +} + +sub _start_task { + my $self = shift; + my ($spec) = @_; + + my $job_id = $spec->{job_id} or die "No job_id provided"; + my $run_stage = $spec->{stage} or die "No stage provided"; + my $res = $spec->{res} or die "No res provided"; + my $res_skip = $spec->{resource_skip}; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; + my $count = @$set; + @$set = grep { $_->{job_id} ne $job_id } @$set; + die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; + + $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); + + # Set the stage, new task hashref + $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; + + $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + push @{$task->{test_args}} => @{$res->{args}}; + + for my $resource (@{$self->{+RESOURCES}}) { + my $class = ref($resource); + my $val = $res->{record}->{$class} // next; + $resource->record($task->{job_id}, $val); + } + + die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; + $self->{+RUNNING_TASKS}->{$job_id} = $task; + + $task->{resource_skip} = $res_skip if $res_skip; + + push @{$self->{+TASK_LIST}} => $task; + + $self->{+RUNNING}++; + $self->{+RUNNING_CATEGORIES}->{$cat}++; + $self->{+RUNNING_DURATIONS}->{$dur}++; + + my $cfls = $task->{conflicts} //= []; + for my $cfl (@$cfls) { + die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" + if $self->{+RUNNING_CONFLICTS}->{$cfl}++; + } + + return; +} + +sub stop_task { + my $self = shift; + my ($job_id) = @_; + $self->_enqueue(stop_task => $job_id); +} + +sub _stop_task { + my $self = shift; + my ($job_id) = @_; + + my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; + + delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; + + $_->release($job_id) for @{$self->{+RESOURCES}}; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + $self->{+RUNNING}--; + $self->{+RUNNING_CATEGORIES}->{$cat}--; + $self->{+RUNNING_DURATIONS}->{$dur}--; + + my $cfls = $task->{conflicts} //= []; + $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; + + return; +} + +sub retry_task { + my $self = shift; + my ($job_id) = @_; + + $self->_enqueue(retry_task => $job_id); +} + +sub _retry_task { + my $self = shift; + my ($job_id) = @_; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; + + $self->_stop_task($job_id); + + return if $self->{+HALTED_RUNS}->{$task->{run_id}}; + + $task = {is_try => 0, %$task}; + $task->{is_try}++; + $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; + + $self->_queue_task($task); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_ready => $stage); +} + +sub _stage_ready { + my $self = shift; + my ($stage, $pid) = @_; + + $self->{+STAGE_READINESS}->{$stage} = $pid // 1; + + return; +} + +sub stage_down { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_down => $stage); +} + +sub _stage_down { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE_READINESS}->{$stage} = 0; + + return; +} + +sub reload { + my $self = shift; + my ($stage, $data) = @_; + $stage //= 'default'; + $self->_enqueue(reload => {%$data, stage => $stage}); + return; +} + +sub _reload { + my $self = shift; + my ($data) = @_; + + my $stage = $data->{stage}; + my $file = $data->{file}; + my $success = $data->{reloaded}; + my $error = $data->{error}; + my $warnings = $data->{warnings}; + + my $reload_state = $self->{+RELOAD_STATE} //= {}; + my $stage_state = $reload_state->{$stage} //= {}; + + # It either succeeded, or the stage will be reloaded, no need to track brokenness + if (defined $success) { + delete $stage_state->{$file}; + } + else { + my $fields = {}; + $fields->{error} = $error if defined($error) && length($error); + $fields->{warnings} = $warnings if $warnings && @{$warnings}; + + if (keys %$fields) { + $stage_state->{$file} = $fields; + } + else { + delete $stage_state->{$file}; + } + } + + return; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + return $wants if $self->{+NO_POLL}; + + return $wants // 'DEFAULT' unless $self->preloader; + return $self->preloader->task_stage($task->{file}, $wants); +} + +sub task_pending_lookup { + my $self = shift; + my ($task) = @_; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; +} + +sub task_fields { + my $self = shift; + my ($task) = @_; + + my $run_id = $task->{run_id} or die "No run id provided by task"; + my $smoke = $task->{smoke} ? 'smoke' : 'main'; + my $stage = $self->task_stage($task); + + my $cat = $task->{category}; + my $dur = $task->{duration}; + + die "Invalid category: $cat" unless CATEGORIES->{$cat}; + die "Invalid duration: $dur" unless DURATIONS->{$dur}; + + $cat = 'conflicts' if $cat eq 'general' && $task->{conflicts} && @{$task->{conflicts}}; + + return ($run_id, $smoke, $stage, $cat, $dur); +} + +sub prune_hash { + my $self = shift; + my ($hash, @path) = @_; + + die "No path!" unless @path; + + my $key = shift @path; + + if (@path) { + my $empty = $self->prune_hash($hash->{$key}, @path); + return 0 unless $empty; + } + + return 1 unless exists $hash->{$key}; + + my $ref = ref($hash->{$key}); + if ($ref eq 'HASH') { + return 0 if keys %{$hash->{$key}}; + } + elsif ($ref eq 'ARRAY') { + return 0 if @{$hash->{$key}}; + } + + delete $hash->{$key}; + return 1; +} + +sub advance_run { + my $self = shift; + + return 0 if $self->{+RUN}; + + return 0 unless @{$self->{+PENDING_RUNS} //= []}; + $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); + + return 1; +} + +sub clear_finished_run { + my $self = shift; + + my $run = $self->{+RUN} or return 0; + + return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; + return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; + return 0 if $self->{+RUNNING}; + + delete $self->{+RUN}; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run->run_id}; + $data->jobs->{$run->run_id}->{closed} = 1; + }); + + return 1; +} + +sub advance_tasks { + my $self = shift; + + for my $resource (@{$self->{+RESOURCES}}) { + $resource->refresh(); + + next unless $resource->job_limiter; + return 0 if $resource->job_limiter_at_max(); + } + + my ($run_stage, $task, $res, %params) = $self->_next(); + + my $out = 0; + if ($task) { + $out = 1; + $self->start_task({job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}); + } + + $_->discharge() for @{$self->{+RESOURCES}}; + + return $out; +} + +sub _cat_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; + + # Only search isolation if nothing is running. + push @cat_order => 'isolation' unless $self->{+RUNNING}; + + return \@cat_order; +} + +sub _dur_order { + my $self = shift; + + my $max = 0; + for my $resource (@{$self->resources}) { + next unless $resource->job_limiter; + my $val = $resource->job_limiter_max; + $max = $val if !$max || $val < $max; + } + $max //= 1; + + my $maxm1 = $max - 1; + + my $durs = $self->{+RUNNING_DURATIONS}; + + # 'short' is always ok. + my @dur_order = ('short'); + + # long and medium should be on the front of the search unless we are + # already running (max - 1) tests of the duration We want long first if + # we are not saturation on them, followed by medium, whcih is why they + # are listed in this order. + for my $c (qw/medium long/) { + if ($durs->{$c} && $durs->{$c} >= $maxm1) { + push @dur_order => $c; # Back of the list + } + else { + unshift @dur_order => $c; # Front of the list + } + } + + return \@dur_order; +} + +# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in +# which we search for tasks, 'RUN_STAGE' is the stage that actually does the +# work. This is what allows us to find tasks for 'eager' stages that are bored. +sub _stage_order { + my $self = shift; + + my $stage_check = $self->{+STAGE_READINESS} //= {}; + + my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; + + # Populate list with all ready stages + my %seen; + my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; + + # Add in any eager stages, but make sure they are last. + for my $rstage (@stage_list) { + next unless exists $self->{+EAGER_STAGES}->{$rstage}; + push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; + } + + return \@stages; +} + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::State - State tracking for the runner. + +=head1 DESCRIPTION + +This module tracks the state for all running tests. This entire module is +considered an "Implementation Detail". Please do not rely on it always staying +the same, or even existing in the future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Settings.pm b/libold2/Test2/Harness/Settings.pm new file mode 100644 index 000000000..91a7b8e5c --- /dev/null +++ b/libold2/Test2/Harness/Settings.pm @@ -0,0 +1,197 @@ +package Test2::Harness::Settings; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp(); +use Scalar::Util(); + +use Test2::Harness::Settings::Prefix; + +sub new { + my $class = shift; + + my $hash; + if (@_ == 1) { + require Test2::Harness::Util::File::JSON; + my $settings_file = Test2::Harness::Util::File::JSON->new(name => $_[0]); + $hash = $settings_file->read; + } + else { + $hash = {@_}; + } + + for my $key (keys %$hash) { + my $val = delete $hash->{$key}; + + if (Scalar::Util::blessed($val)) { + Carp::croak("All prefixes must contain instances of Test2::Harness::Settings::Prefix") + unless $val->isa('Test2::Harness::Settings::Prefix'); + + $hash->{$key} = $val; + next; + } + + Carp::croak("All prefixes must be defined as hashes") + unless ref($val) eq 'HASH'; + + $hash->{$key} = Test2::Harness::Settings::Prefix->new(%$val); + } + + return bless(\$hash, $class); +} + +sub define_prefix { + my $self = shift; + my ($prefix) = @_; + + return ${$self}->{$prefix} //= Test2::Harness::Settings::Prefix->new; +} + +sub check_prefix { + my $self = shift; + my ($prefix) = @_; + return exists(${$self}->{$prefix}); +} + +sub prefix { + my $self = shift; + my ($prefix, @args) = @_; + + Carp::croak("Too many arguments for prefix()") if @args; + Carp::croak("The '$prefix' prefix is not defined") unless ${$self}->{$prefix}; + + return ${$self}->{$prefix}; +} + +sub build { + my $self = shift; + my ($prefix, $class, @args) = @_; + + my $p = $self->prefix($prefix); + + $p->build($class, @args); +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $this = shift; + + my $prefix = $AUTOLOAD; + $prefix =~ s/^.*:://g; + + return if $prefix eq 'DESTROY'; + + Carp::croak("Method $prefix() must be called on a blessed instance") unless ref($this); + Carp::croak("Too many arguments for $prefix()") if @_; + + $this->prefix($prefix); +} + +sub TO_JSON { + my $self = shift; + return {%$$self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Settings - Configuration settings for Test2::Harness. + +=head1 DESCRIPTION + +This module represents the options provided at the command line. Each option +has a prefix, and each prefix can be accessed from the settings. + +=head1 SYNOPSIS + + # You will rarely if ever need to construct settings yourself, usually a + # component of Test2::Harness will expose them to you. + my $settings = $thing->settings; + + # All prefixes have a method generated for them via AUTOLOAD + my $display = $settings->display; + + # You can also use the prefix method + my $display = $settings->prefix('display'); + + + # The prefix can be used in a similar way + my $verbose = $settings->display->verbose; + +See L<Test2::Harness::Settings::Prefix> for more details on how to use the prefixes. + +=head1 METHODS + +Note that any prefix that does not conflict with the predefined methods can be +accessed via AUTOLOAD generating the methods as needed. + +=over 4 + +=item $settings->define_prefix($prefix_name) + +This is used to create a prefix. + +=item $bool = $settings->check_prefix($prefix_name) + +This is used to check if a prefix is defined or not. + +=item $prefix = $settings->prefix($prefix_name) + +=item $prefix = $settings->$prefix_name + +This will retrieve a prefix if it exists. If the prefix is not defined this +will throw an exception. If you are unsure if a prefix exists use +C<$settings->check_prefix($prefix_name)>. + +=item $thing = $settings->build($prefix_name, $class, @args) + +This will create an instance of C<$class> passing the key/value pairs from the +specified prefix as arguments. Additional arguments can be provided in +C<@args>. + +=item $hashref = $settings->TO_JSON() + +This method allows settings to be serialized into JSON. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Settings/Prefix.pm b/libold2/Test2/Harness/Settings/Prefix.pm new file mode 100644 index 000000000..350f33c81 --- /dev/null +++ b/libold2/Test2/Harness/Settings/Prefix.pm @@ -0,0 +1,188 @@ +package Test2::Harness::Settings::Prefix; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp(); +use Test2::Harness::Util(); + +sub new { + my $class = shift; + my $hash = {@_}; + return bless \$hash, $class; +} + +sub vivify_field { + my $self = shift; + my ($field) = @_; + + return \(${$self}->{$field}); +} + +sub check_field { + my $self = shift; + my ($field) = @_; + + return exists ${$self}->{$field}; +} + +sub field : lvalue { + my $self = shift; + my ($field, @args) = @_; + + Carp::croak("Too many arguments for field()") if @args > 1; + Carp::croak("The '$field' field does not exist") unless exists ${$self}->{$field}; + + (${$self}->{$field}) = @args if @args; + + return ${$self}->{$field}; +} + +sub remove_field { + my $self = shift; + my ($field) = @_; + delete ${$self}->{$field}; +} + +our $AUTOLOAD; +sub AUTOLOAD : lvalue { + my $this = shift; + + my $field = $AUTOLOAD; + $field =~ s/^.*:://g; + + return if $field eq 'DESTROY'; + + Carp::croak("Method $field() must be called on a blessed instance") unless ref($this); + Carp::croak("Too many arguments for $field()") if @_ > 1; + + $this->field($field, @_); +} + +sub TO_JSON { + my $self = shift; + return {%$$self}; +} + +sub build { + my $self = shift; + my ($class, @args) = @_; + + require(Test2::Harness::Util::mod2file($class)); + + return $class->new(%$$self, @args); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Settings::Prefix - Abstraction of a settings category, aka prefix. + +=head1 DESCRIPTION + +This class represents a settings category (prefix). + +=head1 SYNOPSIS + + # You will rarely if ever need to construct settings yourself, usually a + # component of Test2::Harness will expose them to you. + my $settings = $thing->settings; + my $display = $settings->display; + + # Once you have your prefix you can read data from it: + my $verbose = $display->verbose; + + # If you dislike autoload methods you can use the 'field' method: + my $verbose = $display->field('verbose'); + + # You can also change values: + $display->field(verbose => 1); + + # You can also use the autoloaded method as an lvalue, but this breaks on + # perls older than 5.16, so it is not used internally, and you should only + # use it if you know you will never need an older perl: + $display->verbose = 1; + +=head1 METHODS + +Note that any field that does not conflict with the predefined methods can be +accessed via AUTOLOAD generating the methods as needed. + +=over 4 + +=item $scalar_ref = $prefix->vivify_field($field_name) + +This will force a field into existance. It returns a scalar reference to the +field which can be used to set the value: + + my $vref = $display->vivify_field('verbose'); # Create or find field + ${$vref} = 1; # set verbosity to 1 + +=item $bool = $prefix->check_field($field_name) + +Check if a field is defined or not. + +=item $val = $prefix->field($field_name) + +=item $val = $prefix->$field_name + +=item $prefix->field($field_name, $val) + +=item $prefix->$field_name = $val + +Retrieve or set the value of the specified field. This will throw an exception +if the field does not exist. + +B<Note>: The lvalue form C<< $prefix->$field_name = $val >> breaks on perls +older then 5.16. + +=item $thing = $prefix->build($class, @args) + +This will create an instance of C<$class> passing the key/value pairs from the +prefix as arguments. Additional arguments can be provided in C<@args>. + +=item $hashref = $prefix->TO_JSON() + +This method allows settings to be serialized into JSON. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/State.pm b/libold2/Test2/Harness/State.pm new file mode 100644 index 000000000..07f9b298c --- /dev/null +++ b/libold2/Test2/Harness/State.pm @@ -0,0 +1,301 @@ +package Test2::Harness::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; + +use Test2::Harness::State::Instance; +use Test2::Harness::Settings; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util qw/mod2file clean_path/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <workdir + + +resources +resource_list + +plugins +plugin_list +plugin_lookup + +renderer +renderer_list +renderer_lookup + +job_count + + <observe + }, +); + +sub state_class { 'Test2::Harness::State::Instance' } + +sub access_id { $_[0]->_access->[0] } +sub access_pid { $_[0]->_access->[1] } +sub registered { $_[0]->_access->[2] } + +sub _access { + my $self = shift; + + my $id = $self->{+ACCESS_ID}; + my $pid = $self->{+ACCESS_PID}; + + if (defined $pid) { + return [$id // $pid, $pid, $self->{+REGISTERED} ? 1 : 0] if $pid && $pid == $$; + } + + if(defined($id) || defined($pid)) { + delete $self->{+ACCESS_ID}; + delete $self->{+ACCESS_PID}; + } + + if (my $rpid = $self->{+REGISTERED}) { + delete $self->{+REGISTERED} unless $rpid == $$; + } + + return [$$, $$, $self->{+REGISTERED} ? 1 : 0]; +} + +sub init { + my $self = shift; + + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + $self->SUPER::init(); + + my @bad = grep { !$self->can(uc($_)) } keys %$self; + croak "The following invalid keys were passed into the constructor: " . join(', ' => @bad) + if @bad; + + $self->{+PLUGIN_LOOKUP} //= {}; +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->SUPER::sync_from_state($state); + + $self->{+WORKDIR} = $state->{workdir}; +} + +sub init_state { + my $self = shift; + + confess "Attempt to initialize state from an observer" + if $self->{+OBSERVE}; + + my $state = $self->SUPER::init_state(@_); + + $state = $self->state_class->init_state($self, $state); + + return $state; +} + +sub settings { + my $self = shift; + return $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[1]->settings}) }); +} + +sub job_count { + my $self = shift; + return $self->{+JOB_COUNT} //= $self->transaction(r => sub { $_[1]->job_count }); +} + +sub _init_resources { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + my $has_limiter = undef; + + for my $res (@$list) { + my ($type, $inst); + if ($type = ref($res)) { + $inst = $res; + } + else { + $type = $res; + require(mod2file($res)); + $inst = $res->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + push @inst => $inst; + push @store => $type; + + $has_limiter ||= $inst->job_limiter; + } + + unless ($has_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + push @store => 'Test2::Harness::Runner::Resource::JobCount'; + push @inst => Test2::Harness::Runner::Resource::JobCount->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + return (\@store, \@inst); +} + +sub resource_list { + my $self = shift; + return $self->{+RESOURCE_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $list; + }); +} + +sub resources { + my $self = shift; + return $self->{+RESOURCES} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $inst; + }); +} + +sub _init_plugins { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + for my $p (@$list) { + my ($type, $inst); + if ($type = ref($p)) { + $inst = $p; + } + else { + $type = $p; + require(mod2file($p)); + $inst = $p->new(settings => $settings) if $p->can('new'); + } + + push @store => $type; + push @inst => $inst; + } + + return (\@store, \@inst); +} + +sub plugin_list { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGIN_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $list; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "MODS-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +sub plugins { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGINS} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $inst; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "INST-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State - State tracking for a yath instance + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/State/Instance.pm b/libold2/Test2/Harness/State/Instance.pm new file mode 100644 index 000000000..2edca3303 --- /dev/null +++ b/libold2/Test2/Harness/State/Instance.pm @@ -0,0 +1,111 @@ +package Test2::Harness::State::Instance; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <resources + <job_count + <settings + <workdir + <plugins + <runs + <ipc_model + <jobs + <queue + + <processes + <aggregators + }, +); + +sub init_state { + my $class = shift; + my ($state, $data) = @_; + + $data->{+WORKDIR} //= $state->{workdir} // confess "No workdir"; + $data->{+SETTINGS} //= $state->{settings} // confess "No settings"; + my $settings = $data->{settings}; + + $data->{+JOBS} //= {}; + $data->{+QUEUE} //= {}; + $data->{+IPC_MODEL} //= {}; + $data->{+JOB_COUNT} //= $state->{job_count} // $settings->check_prefix('runner') ? $settings->runner->job_count // 1 : 1; + + $data->{+PROCESSES} //= {}; + $data->{+AGGREGATORS} //= {}; + + for my $type (qw/resource plugin renderer/) { + my $plural = "${type}s"; + my $raw; + + if ($type eq 'resource') { + next unless $settings->check_prefix('runner'); + $raw = $settings->runner->$plural // []; + @$raw = sort { $a->sort_weight <=> $b->sort_weight } @$raw; + } + else { + next unless $settings->check_prefix('harness'); + next unless $settings->harness->check_field($plural); + $raw = $settings->harness->$plural // []; + } + + $data->{$plural} = [map { ref($_) || $_ } @$raw]; + } + + return bless($data, $class); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State::Instance - Data structure for yath shared state + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/TestFile.pm b/libold2/Test2/Harness/TestFile.pm new file mode 100644 index 000000000..6381b1b79 --- /dev/null +++ b/libold2/Test2/Harness/TestFile.pm @@ -0,0 +1,695 @@ +package Test2::Harness::TestFile; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Time::HiRes qw/time/; + +use List::Util 1.45 qw/uniq/; + +use Test2::Harness::Util qw/open_file clean_path/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <file +relative <_scanned <_headers +_shbang <is_binary <non_perl + input env_vars test_args + queue_args + job_class + comment + _category _stage _duration _min_slots _max_slots +}; + +sub set_duration { $_[0]->set__duration(lc($_[1])) } +sub set_category { $_[0]->set__category(lc($_[1])) } + +sub set_stage { $_[0]->set__stage($_[1]) } +sub set_min_slots { $_[0]->set__min_slots($_[1]) } +sub set_max_slots { $_[0]->set__max_slots($_[1]) } + +sub retry { $_[0]->headers->{retry} } +sub set_retry { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry} = $val; +} + +sub retry_isolated { $_[0]->headers->{retry_isolated} } +sub set_retry_isolated { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry_isolated} = $val; +} + +sub set_smoke { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{features}->{smoke} = $val; +} + +sub init { + my $self = shift; + + my $file = $self->file; + + # We want absolute path + $file = clean_path($file, 0); + $self->{+FILE} = $file; + + $self->{+QUEUE_ARGS} ||= []; + + croak "Invalid test file '$file'" unless -f $file; + + if($self->{+IS_BINARY} = -B $file && !-z $file) { + $self->{+NON_PERL} = 1; + die "Cannot run binary test file '$file': file is not executable.\n" + unless $self->is_executable; + } +} + +sub relative { + my $self = shift; + return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE}); +} + +my %DEFAULTS = ( + timeout => 1, + fork => 1, + preload => 1, + stream => 1, + run => 1, + isolation => 0, + smoke => 0, + io_events => 1, +); + +sub check_feature { + my $self = shift; + my ($feature, $default) = @_; + + $default = $DEFAULTS{$feature} unless defined $default; + + return $default unless defined $self->headers->{features}->{$feature}; + return 1 if $self->headers->{features}->{$feature}; + return 0; +} + +sub check_stage { + my $self = shift; + + return $self->{+_STAGE} if $self->{+_STAGE}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{stage} || undef; +} + +sub check_min_slots { + my $self = shift; + + return $self->{+_MIN_SLOTS} if $self->{+_MIN_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{min_slots} // undef; +} + +sub check_max_slots { + my $self = shift; + + return $self->{+_MAX_SLOTS} if $self->{+_MAX_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{max_slots} // undef; +} + +sub meta { + my $self = shift; + my ($key) = @_; + + $self->_scan unless $self->{+_SCANNED}; + my $meta = $self->{+_HEADERS}->{meta} or return (); + + return () unless $key && $meta->{$key}; + + return @{$meta->{$key}}; +} + +sub check_duration { + my $self = shift; + + return $self->{+_DURATION} if $self->{+_DURATION}; + + $self->_scan unless $self->{+_SCANNED}; + my $duration = $self->{+_HEADERS}->{duration}; + return $duration if $duration; + + my $timeout = $self->check_feature(timeout => 1); + + # 'long' for anything with no timeout + return 'long' unless $timeout; + + return 'medium'; +} + +sub check_category { + my $self = shift; + + return $self->{+_CATEGORY} if $self->{+_CATEGORY}; + + $self->_scan unless $self->{+_SCANNED}; + my $category = $self->{+_HEADERS}->{category}; + + return $category if $category; + + my $isolate = $self->check_feature(isolation => 0); + + # 'isolation' queue if isolation requested + return 'isolation' if $isolate; + + return 'general'; +} + +sub event_timeout { $_[0]->headers->{timeout}->{event} } +sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} } + +sub conflicts_list { + return $_[0]->headers->{conflicts} || []; # Assure conflicts is always an array ref. +} + +sub headers { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_HEADERS}; + return {%{$self->{+_HEADERS}}}; +} + +sub shbang { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_SHBANG}; + return {%{$self->{+_SHBANG}}}; +} + +sub switches { + my $self = shift; + + my $shbang = $self->shbang or return []; + my $switches = $shbang->{switches} or return []; + + return $switches; +} + +sub is_executable { + my $self = shift; + my ($file) = @_; + $file //= $self->{+FILE}; + return -x $file; +} + +sub scan { + my $self = shift; + $self->_scan(); + return; +} + +sub _scan { + my $self = shift; + + return if $self->{+_SCANNED}++; + return if $self->{+IS_BINARY}; + + my $fh = open_file($self->{+FILE}); + my $comment = $self->{+COMMENT} // '#'; + + my %headers; + for (my $ln = 1; my $line = <$fh>; $ln++) { + chomp($line); + next if $line =~ m/^\s*$/; + + if ($ln == 1 && $line =~ m/^#!/) { + my $shbang = $self->_parse_shbang($line); + if ($shbang) { + $self->{+_SHBANG} = $shbang; + + if ($shbang->{non_perl}) { + $self->{+NON_PERL} = 1; + + die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n" + unless $self->is_executable; + } + + next; + } + } + + # Uhg, breaking encapsulation between yath and the harness + if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) { + $headers{features}->{run} = 0; + next; + } + + next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/; # Ignore commented lines which aren't HARNESS-? + next if $line =~ m/^\s*(use|require|BEGIN|package)\b/; # Only supports single line BEGINs + last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/; + + my ($dir, $rest) = split /[-\s]+/, $1, 2; + $dir = lc($dir); + my @args; + if ($dir eq 'meta') { + @args = split /\s+/, $rest, 2; # Check for white space delimited + @args = split(/[-]+/, $rest, 2) if scalar @args == 1; # Check for dash delimited + $args[1] =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + } + elsif ($rest) { + $rest =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + @args = split /[-\s]+/, $rest; + } + + if ($dir eq 'no') { + my $feature = lc(join '_' => @args); + if ($feature eq 'retry') { + $headers{retry} = 0 + } else { + $headers{features}->{$feature} = 0; + } + } + elsif ($dir eq 'smoke') { + $headers{features}->{smoke} = 1; + } + elsif ($dir eq 'retry') { + $headers{retry} = 1 unless @args || defined $headers{retry}; + for my $arg (@args) { + if ($arg =~ m/^\d+$/) { + $headers{retry} = int $arg; + } + elsif ($arg =~ m/^iso/i) { + $headers{retry} //= 1; + $headers{retry_isolated} = 1; + } + else { + warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n"; + } + } + } + elsif ($dir eq 'yes' || $dir eq 'use') { + my $feature = lc(join '_' => @args); + $headers{features}->{$feature} = 1; + } + elsif ($dir eq 'stage') { + my ($name) = @args; + $headers{stage} = $name; + } + elsif ($dir eq 'meta') { + my ($key, $val) = @args; + $key = lc($key); + push @{$headers{meta}->{$key}} => $val; + } + elsif ($dir eq 'duration' || $dir eq 'dur') { + my ($name) = @args; + $name = lc($name); + $headers{duration} = $name; + } + elsif ($dir eq 'category' || $dir eq 'cat') { + my ($name) = @args; + $name = lc($name); + if ($name =~ m/^(long|medium|short)$/i) { + $headers{duration} = $name; + } + else { + $headers{category} = $name; + } + } + elsif ($dir eq 'conflicts') { + my @conflicts_array; + + foreach my $arg (@args) { + push @conflicts_array, lc($arg); + } + + # Allow multiple lines with # HARNESS-CONFLICTS FOO + $headers{conflicts} ||= []; + push @{$headers{conflicts}}, @conflicts_array; + + # Make sure no more than 1 conflict is ever present. + @{$headers{conflicts}} = uniq @{$headers{conflicts}}; + } + elsif ($dir eq 'timeout') { + my ($type, $num, $extra) = @args; + $type = lc($type); + $num = lc($num); + + ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit'; + + warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n" + unless $type =~ m/^(event|postexit)$/; + + $headers{timeout}->{$type} = $num; + } + elsif ($dir eq 'job' && $rest =~ m/slots\s+(\d+)(?:\s+(\d+))?$/i) { + $headers{min_slots} //= $1; + $headers{max_slots} //= $2 ? $2 : $1; + } + else { + warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n"; + } + } + + $self->{+_HEADERS} = \%headers; +} + +sub _parse_shbang { + my $self = shift; + my $line = shift; + + return {} if !defined $line; + + my %shbang; + + # NOTE: Test this, the dashes should be included with the switches + my $shbang_re = qr{ + ^ + \#!.*perl.*? # the perl path + (?: \s (-.+) )? # the switches, maybe + \s* + $ + }xi; + + if ($line =~ $shbang_re) { + my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; + $shbang{switches} = \@switches; + $shbang{line} = $line; + } + elsif ($line =~ m/^#!/ && $line !~ m/perl/i) { + $shbang{line} = $line; + $shbang{non_perl} = 1; + } + + return \%shbang; +} + +sub queue_item { + my $self = shift; + my ($job_name, $run_id, %inject) = @_; + + die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n" + unless $self->check_feature(run => 1); + + my $category = $self->check_category; + my $duration = $self->check_duration; + my $stage = $self->check_stage; + my $min_slots = $self->check_min_slots; + my $max_slots = $self->check_max_slots; + + my $smoke = $self->check_feature(smoke => 0); + my $fork = $self->check_feature(fork => 1); + my $preload = $self->check_feature(preload => 1); + my $timeout = $self->check_feature(timeout => 1); + my $stream = $self->check_feature(stream => 1); + my $io_events = $self->check_feature(io_events => 1); + + my $retry = $self->retry; + my $retry_isolated = $self->retry_isolated; + + my $binary = $self->{+IS_BINARY} ? 1 : 0; + my $non_perl = $self->{+NON_PERL} ? 1 : 0; + + my $et = $self->event_timeout; + my $pet = $self->post_exit_timeout; + + my $job_class = $self->job_class; + + my $input = $self->input; + my $test_args = $self->test_args; + + my $env_vars = $self->env_vars; + if ($env_vars) { + my $mix = delete $inject{env_vars}; + $env_vars = {%$mix, %$env_vars} if $mix; + } + + return { + binary => $binary, + category => $category, + conflicts => $self->conflicts_list, + duration => $duration, + file => $self->file, + rel_file => $self->relative, + job_id => gen_uuid(), + job_name => $job_name, + run_id => $run_id, + non_perl => $non_perl, + stage => $stage, + stamp => time, + switches => $self->switches, + use_fork => $fork, + use_preload => $preload, + use_stream => $stream, + use_timeout => $timeout, + smoke => $smoke, + io_events => $io_events, + rank => $self->rank, + + defined($input) ? (input => $input) : (), + defined($env_vars) ? (env_vars => $env_vars) : (), + defined($test_args) ? (test_args => $test_args) : (), + defined($job_class) ? (job_class => $job_class) : (), + defined($retry) ? (retry => $retry) : (), + defined($retry_isolated) ? (retry_isolated => $retry_isolated) : (), + defined($et) ? (event_timeout => $et) : (), + defined($pet) ? (post_exit_timeout => $self->post_exit_timeout) : (), + defined($min_slots) ? (min_slots => $min_slots) : (), + defined($max_slots) ? (max_slots => $max_slots) : (), + + @{$self->{+QUEUE_ARGS}}, + + %inject, + }; +} + +my %RANK = ( + smoke => 1, + immiscible => 10, + long => 20, + medium => 50, + short => 80, + isolation => 100, +); + +sub rank { + my $self = shift; + + return $RANK{smoke} if $self->check_feature('smoke'); + + my $rank = $RANK{$self->check_category}; + $rank ||= $RANK{$self->check_duration}; + $rank ||= 1; + + return $rank; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::TestFile - Abstraction of a test file and its meta-data. + +=head1 DESCRIPTION + +When Test2::Harness finds test files to run each one gets an instance of this +class to represent it. This class will scan test files to find important meta +data (binary vs script, inline harness directives, etc). The meta-data this +class can find helps yath decide when and how to run the test. + +If you write a custom L<Test2::Harness::Finder> or use some +L<Test2::Harness::Plugin> callbacks you may have to use, or even construct +instances of this class. + +=head1 SYNOPSIS + + use Test2::Harness::TestFile; + + my $tf = Test2::Harness::TestFile->new(file => "path/to/file.t"); + + # For an example 1, 1 works, but normally they are job_name and run_id. + my $meta_data = $tf->queue_item(1, 1); + + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $tf->file + +Set during object construction, and cannot be changed. + +=item $bool = $tf->is_binary + +Automatically set during construction, cannot be changed or set manually. + +=item $bool = $tf->non_perl + +Automatically set during construction, cannot be changed or set manually. + +=item $string = $tf->comment + +=item $tf->set_comment($string) + +Defaults to '#' can be set during construction, or changed if needed. + +This is used to tell yath what character(s) are used to denote a comment. This +is necessary for finding harness directives. In perl the '#' character is used, +and that is the default value. This is here to support non-perl tests. + +=item $class = $tf->job_class + +=item $tf->set_job_class($class) + +Default it undef (let the runner pick). You can change this if you want the +test to run with a custom job subclass. + +=item $arrayref = $tf->queue_args + +=item $tf->set_queue_args(\@ARGS) + +Key/Value pairs to append to the queue_item() data. + +=back + +=head1 METHODS + +=over 4 + +=item $cat = $tf->check_category() + +=item $tf->set_category($cat) + +This is how you find the category for a file. You can use C<set_category()> to +assign/override a category. + +=item $dur = $tf->check_duration() + +=item $tf->set_duration($dur) + +Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override +with C<set_duration()>. + +=item $stage = $tf->check_stage() + +=item $tf->set_stage($stage) + +Get the preload stage the test file thinks it should be run in. You can +override with C<set_stage()>. + +=item $bool = $tf->check_feature($name) + +This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or +C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES> +and C<USE> will result in a ture boolean. If no directive is found then +C<undef> will be returned. + +=item $arrayref = $tf->conflicts_list() + +Get a list of conflict markers. + +=item $seconds = $tf->event_timeout() + +If they test specifies an event timeout this will return it. + +=item %headers = $tf->headers() + +This returns the header data from the test file. + +=item $bool = $tf->is_executable() + +Check if the test file is executable or not. + +=item $data = $tf->meta($key) + +Get the meta-data for the specific key. + +=item $seconds = $tf->post_exit_timeout() + +If the test file has a custom post-exit timeout, this will return it. + +=item $hashref = $tf->queue_item($job_name, $run_id) + +This returns the data used to add the test file to the runner queue. + +=item $int = $tf->rank() + +Returns an integer value used to sort tests into an efficient run order. + +=item $path = $tf->relative() + +Relative path to the test file. + +=item $tf->scan() + +Scan the file and populate the header data. Return nothing, takes no arguments. +Automatically run by things that require the scan data. Results are cached. + +=item $tf->set_smoke($bool) + +Set smoke status. Smoke tests go to the front of the line when tests are +sorted. + +=item $hashref = $tf->shbang() + +Get data gathered from parsing the tests shbang line. + +=item $arrayref = $tf->switches() + +A list of switches passed to perl, usually from the shbang line. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util.pm b/libold2/Test2/Harness/Util.pm new file mode 100644 index 000000000..976b29785 --- /dev/null +++ b/libold2/Test2/Harness/Util.pm @@ -0,0 +1,651 @@ +package Test2::Harness::Util; +use strict; +use warnings; + +use Carp qw/confess/; +use Cwd qw/realpath/; +use List::Util qw/min/; +use Test2::Util qw/try_sig_mask do_rename/; +use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; +use File::Spec; + +use List::Util qw/zip/; +use Config qw/%Config/; + +my @SIGNUMS = split(' ', $Config{sig_num}); +my @SIGNAMES = split(' ', $Config{sig_name}); + +my %SIG_NUM_LOOKUP = map { @$_ } zip(\@SIGNAMES, \@SIGNUMS); +my %SIG_NAME_LOOKUP = map { @$_ } zip(\@SIGNUMS, \@SIGNAMES); + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + find_libraries + clean_path + + sig_name_to_num + sig_num_to_name + parse_exit + mod2file + file2mod + fqmod + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + lock_file + unlock_file + + hub_truth + + apply_encoding + + process_includes + + chmod_tmp + + looks_like_uuid + is_same_file + + resize_pipe +}; + +sub resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh, $size) = @_; + + # 1mb if we can + $size //= 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub is_same_file { + my ($file1, $file2) = @_; + + return 0 unless defined $file1; + return 0 unless defined $file2; + + return 1 if "$file1" eq "$file2"; + return 1 if clean_path($file1) eq clean_path($file2); + + return 0 unless -e $file1; + return 0 unless -e $file2; + + my ($dev1, $inode1) = stat($file1); + my ($dev2, $inode2) = stat($file2); + + return 0 unless $dev1 == $dev2; + return 0 unless $inode1 == $inode2; + return 1; +} + +sub looks_like_uuid { + my ($in) = @_; + + return undef unless defined $in; + return undef unless length($in) == 36; + return undef unless $in =~ m/^[0-9A-F\-]+$/i; + return $in; +} + +sub chmod_tmp { + my $file = shift; + + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; + + chmod($mode, $file); +} + +sub process_includes { + my %params = @_; + + my @start = @{delete $params{list} // []}; + + my @list; + my %seen = ('.' => 1); + + if (my $ch_dir = delete $params{ch_dir}) { + for my $path (@start) { + # '.' is special. + $seen{'.'}++ and next if $path eq '.'; + + if (File::Spec->file_name_is_absolute($path)) { + push @list => $path; + } + else { + push @list => File::Spec->catdir($ch_dir, $path); + } + } + } + else { + @list = @start; + } + + push @list => @INC if delete $params{include_current}; + + @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + + @list = grep { !$seen{$_}++ } @list; + + # If we ask for dot, or saw it during our processing, add it to the end. + push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; + + confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + + return @list; +} + +sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); +} + +sub sig_name_to_num { $SIG_NUM_LOOKUP{$_} } +sub sig_num_to_name { $SIG_NAME_LOOKUP{$_} } + +sub parse_exit { + my ($exit) = @_; + + my $sig = $exit & 127; + my $dmp = $exit & 128; + + return { + $sig ? (signame => $SIG_NAME_LOOKUP{$sig} // 'N/A') : (), + sig => $sig, + err => ($exit >> 8), + dmp => $dmp, + all => $exit, + }; +} + +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return $input if $input =~ m/^\Q${prefix}::\E/; + return "$prefix\::$input"; +} + +sub hub_truth { + my ($f) = @_; + + return $f->{hubs}->[0] if $f->{hubs} && @{$f->{hubs}}; + return $f->{trace} if $f->{trace}; + return {}; +} + +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} + +sub read_file { + my ($file, @args) = @_; + + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); + + return $out; +} + +sub write_file { + my ($file, @content) = @_; + + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); + + return @content; +}; + +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; + + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); + + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } + } + + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} + +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} + +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} + +sub write_file_atomic { + my ($file, @content) = @_; + + my $pend = "$file.pend"; + + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; + + die $err unless $ok; + + return @content; +} + +sub lock_file { + my ($file, $mode) = @_; + + my $fh; + if (ref $file) { + $fh = $file; + } + else { + open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; + } + + for (1 .. 21) { + flock($fh, LOCK_EX) and last; + die "Could not lock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not lock file: $!"; + } + + return $fh; +} + +sub unlock_file { + my ($fh) = @_; + for (1 .. 21) { + flock($fh, LOCK_UN) and last; + die "Could not unlock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not unlock file: $!"; + } + + return $fh; +} + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub mod2file { + my ($mod) = @_; + confess "No module name provided" unless $mod; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + return $file; +} + +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; +} + + +sub find_libraries { + my ($search, @paths) = @_; + my @parts = grep $_, split /::(\*)?/, $search; + + @paths = @INC unless @paths; + + @paths = map { File::Spec->canonpath($_) } @paths; + + my %prefixes = map {$_ => 1} @paths; + + my @found; + my @bases = ([map { [$_ => length($_)] } @paths]); + while (my $set = shift @bases) { + my $new_base = []; + my $part = shift @parts; + + for my $base (@$set) { + my ($dir, $prefix) = @$base; + if ($part ne '*') { + my $path = File::Spec->catdir($dir, $part); + if (@parts) { + push @$new_base => [$path, $prefix] if -d $path; + } + elsif (-f "$path.pm") { + push @found => ["$path.pm", $prefix]; + } + + next; + } + + opendir(my $dh, $dir) or next; + for my $item (readdir($dh)) { + next if $item =~ m/^\./; + my $path = File::Spec->catdir($dir, $item); + if (@parts) { + # Sometimes @INC dirs are nested in eachother. + next if $prefixes{$path}; + + push @$new_base => [$path, $prefix] if -d $path; + next; + } + + next unless -f $path && $path =~ m/\.pm$/; + push @found => [$path, $prefix]; + } + } + + push @bases => $new_base if @$new_base; + } + + my %out; + for my $found (@found) { + my ($path, $prefix) = @$found; + + my @file_parts = File::Spec->splitdir(substr($path, $prefix)); + shift @file_parts if $file_parts[0] eq ''; + + my $file = join '/' => @file_parts; + $file_parts[-1] = substr($file_parts[-1], 0, -3); + my $module = join '::' => @file_parts; + + $out{$module} //= $file; + } + + return \%out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util - General utiliy functions. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 MISC + +=over 4 + +=item apply_encoding($fh, $enc) + +Apply the specified encoding to the filehandle. + +B<Justification>: +L<PERLBUG 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923> +If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in +order to avoid the thread segfault. + +This is a reusable implementation of this: + + sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); + } + +=item $clean = clean_path($path) + +Take a file path and clean it up to a minimal absolute path if possible. Always +returns a path, but if it cannot be cleaned up it is unchanged. + +=item $hashref = find_libraries($search) + +=item $hashref = find_libraries($search, @paths) + +C<@INC> is used if no C<@paths> are provided. + +C<$search> should be a module name with C<*> wildcards replacing sections. + + find_libraries('Foo::*::Baz') + find_libraries('*::Bar::Baz') + find_libraries('Foo::Bar::*') + +These all look for modules matching the search, this is a good way to find +plugins, or similar patterns. + +The result is a hashref of C<< { $module => $path } >>. If a module exists in +more than 1 search path the first is used. + +=item $mod = fqmod($prefix, $mod) + +This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If +C<$mod> starts with the C<'+'> character the character will be removed and the +result returned without prepending C<$prefix>. + +=item hub_truth + +This is an internal implementation detail, do not use it. + +=item $hashref = parse_exit($?) + +This parses the exit value as typically stored in C<$?>. + +Resulting hash: + + { + sig => ($? & 127), # Signal value if the exit was caused by a signal + err => ($? >> 8), # Actual exit code, if any. + dmp => ($? & 128), # Was there a core dump? + all => $?, # Original exit value, unchanged + } + + +=item @list = process_includes(%PARAMS) + +This method will build up a list of include dirs fit for C<@INC>. The returned +list should contain only unique values, in proper order. + +Params: + +=over 4 + +=item list => \@START + +Paths to start the new list. + +Optional. + +=item ch_dir => $path + +Prefix to prepend to all paths in the C<list> param. No effect without an +initial list. + +=item include_current => $bool + +This will add all paths from C<@INC> to the output, after the initial list. +Note that '.', if in C<@INC> will be moved to the end of the final output. + +=item clean => $bool + +If included all paths except C<'.'> will be cleaned using C<clean_path()>. + +=item include_dot => $bool + +If true C<'.'> will be appended to the end of the output. + +B<Note> even if this is set to false C<'.'> may still be included if it was in +the initial list, or if it was in C<@INC> and C<@INC> was included using the +C<include_current> parameter. + +=back + +=back + +=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION + +These convert between module names like C<Foo::Bar> and filenames like +C<Foo/Bar.pm>. + +=over 4 + +=item $file = mod2file($mod) + +=item $mod = file2mod($file) + +=back + +=head2 FOR READING/WRITING FILES + +=over 4 + +=item $fh = open_file($path, $mode) + +=item $fh = open_file($path) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = read_file($file) + +This will open the file at C<$path> and return all its contents. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $fh = maybe_open_file($path) + +=item $fh = maybe_open_file($path, $mode) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +C<undef> is returned if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = maybe_read_file($path) + +This will open the file at C<$path> and return all its contents. + +This will return C<undef> if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item @content = write_file($path, @content) + +Write content to the specified file. This will open the file with mode +C<< '>' >>, write the content, then close the file. + +An exception will be thrown if any part fails. + +=item @content = write_file_atomic($path, @content) + +This will open a temporary file, write the content, close the file, then rename +the file to the desired C<$path>. This is essentially an atomic write in that +C<$file> will not exist until all content is written, preventing other +processes from doing a partial read while C<@content> is being written. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/File.pm b/libold2/Test2/Harness/Util/File.pm new file mode 100644 index 000000000..6a19341f1 --- /dev/null +++ b/libold2/Test2/Harness/Util/File.pm @@ -0,0 +1,256 @@ +package Test2::Harness::Util::File; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IO::Handle; + +use Test2::Harness::Util(); + +use Carp qw/croak confess/; +use Fcntl qw/SEEK_SET SEEK_CUR/; + +use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos <skip_bad_decode }; + +sub exists { -e $_[0]->{+NAME} } + +sub decode { shift; $_[0] } +sub encode { shift; $_[0] } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+_INIT_FH} = delete $self->{fh}; +} + +sub open_file { + my $self = shift; + return Test2::Harness::Util::open_file($self->{+NAME}, @_) +} + +sub maybe_read { + my $self = shift; + return undef unless -e $self->{+NAME}; + return $self->read; +} + +sub read { + my $self = shift; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +sub rewrite { + my $self = shift; + return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); +} + +sub write { + my $self = shift; + return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); +} + +sub reset { + my $self = shift; + delete $self->{+_FH}; + delete $self->{+DONE}; + delete $self->{+LINE_POS}; + return; +} + +sub fh { + my $self = shift; + return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; + + # Remove any other PID handles + $self->{+_FH} = {}; + + if (my $fh = $self->{+_INIT_FH}) { + $self->{+_FH}->{$$} = $fh; + } + else { + $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; + } + + $self->{+_FH}->{$$}->blocking(0); + return $self->{+_FH}->{$$}; +} + +sub read_line { + my $self = shift; + my %params = @_; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; + seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" + if eof($fh) || tell($fh) != $pos; + + my $line = <$fh>; + + # No line, nothing to do + return unless defined $line && length($line); + + # Partial line, hold off unless done + return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; + + my $new_pos = tell($fh); + die "Failed to 'tell': $!" if $new_pos == -1; + + my $err = 0; + local $@; + unless (eval { $line = $self->decode($line); 1 }) { + $err = $@ // 'error'; + confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; + warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; + $line = undef; + } + + $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; + return $line unless wantarray; + return ($pos, $new_pos, $line, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File - Utility class for manipulating a file. + +=head1 DESCRIPTION + +This is a utility class for file operations. This also serves as a base class +for several file helpers. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File; + + my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); + + $f->write($content); + + my $fh = $f->open_file('<'); + + # Read, throw exception if it cannot read + my $content = $f->read(); + + # Try to read, but do not throw an exception if it cannot be read. + my $content_or_undef = $f->maybe_read(); + + my $line1 = $f->read_line(); + my $line2 = $f->read_line(); + ... + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $f->name; + +Get the filename. Must also be provided during construction. + +=item $bool = $f->done; + +True if read_line() has read every line. + +=back + +=head1 METHODS + +=over 4 + +=item $decoded = $f->decode($encoded) + +This is a no-op, it returns the argument unchanged. This is called by C<read> +and C<read_line>. Subclasses can override this if the file contains encoded +data. + +=item $encoded = $f->encode($decoded) + +This is a no-op, it returns the argument unchanged. This is called by C<write>. +Subclasses can override this if the file contains encoded data. + +=item $bool = $f->exists() + +Check if the file exists + +=item $content = $f->maybe_read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will return undef. + +=item $fh = $f->open_file() + +=item $fh = $f->open_file($mode) + +Open a handle to the file. If no $mode is provided C<< '<' >> is used. + +=item $content = $f->read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will throw an exception. + +=item $line = $f->read_line() + +Read a single line from the file, subsequent calls will read the next line and +so on until the end of the file is reached. Reset with the C<reset()> method. + +=item $f->reset() + +Reset the internal line iterator used by C<read_line()>. + +=item $f->write($content) + +This is an atomic-write. First $content will be written to a temporary file +using C<< '>' >> mode. Then the temporary file will be renamed to the desired +file name. Under the hood this uses C<write_file_atomic()> from +L<Test2::Harness::Util>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/File/JSON.pm b/libold2/Test2/Harness/Util/File/JSON.pm new file mode 100644 index 000000000..f3f6c5a1e --- /dev/null +++ b/libold2/Test2/Harness/Util/File/JSON.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSON; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/pretty/; + +sub decode { shift; decode_json(@_) } +sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } + +sub reset { croak "line reading is disabled for json files" } +sub read_line { croak "line reading is disabled for json files" } + +sub maybe_read { + my $self = shift; + + return undef unless -e $self->{+NAME}; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + return undef unless defined($out) && length($out); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSON - Utility class for a JSON file. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> which automatically handles +encoding/decoding JSON data. + +=head1 SYNOPSIS + + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); + + $hash = $file->read; + # or + $$file->write({...}); + +=head1 SEE ALSO + +See the base class L<Test2::Harness::Util::File> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/File/JSONL.pm b/libold2/Test2/Harness/Util/File/JSONL.pm new file mode 100644 index 000000000..ce64c51b3 --- /dev/null +++ b/libold2/Test2/Harness/Util/File/JSONL.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSONL; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::Util::File::Stream'; +use Test2::Harness::Util::HashBase; + +sub decode { shift; decode_json($_[0]) } +sub encode { shift; encode_json(@_) . "\n" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> which automatically handles +encoding/decoding JSONL data. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + while (1) { + my @items = $jsonl->poll(max => 1000) or last; + for my $item (@items) { + ... handle $item ... + } + } + +or + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + $jsonl->write({my => 'item', ... }); + ... + +=head1 SEE ALSO + +See the base classes L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/File/Stream.pm b/libold2/Test2/Harness/Util/File/Stream.pm new file mode 100644 index 000000000..a4fa486ca --- /dev/null +++ b/libold2/Test2/Harness/Util/File/Stream.pm @@ -0,0 +1,222 @@ +package Test2::Harness::Util::File::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/lock_file unlock_file/; +use Fcntl qw/SEEK_SET/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/use_write_lock -tail +_wfh +_wpid/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + my $tail = $self->{+TAIL} or return; + + return unless $self->exists; + + my @lines = $self->poll_with_index; + if (@lines < $self->{+TAIL}) { + $self->seek(0); + } + else { + $self->seek($lines[0 - $tail]->[0]); + } +} + +my $seen_warn = 0; +sub poll_with_index { + my $self = shift; + my %params = @_; + + my $max = delete $params{max} || 0; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + warn "Test This!!!" unless $seen_warn++; # Added for 2.0 + return unless $pos < -s $self->name; + + my @out; + while (!$max || @out < $max) { + my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); + last unless defined($line) || defined($spos) || defined($epos) || $err; + + $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; + push @out => [$spos, $epos, $line] unless $err; + $pos = $epos; + } + + return @out; +} + +sub read { + my $self = shift; + + return $self->poll(from => 0); +} + +sub poll { + my $self = shift; + my @lines = $self->poll_with_index(@_); + return map { $_->[-1] } @lines; +} + +sub write { + my $self = shift; + + my $name = $self->{+NAME}; + + my $fh; + if ($self->{+USE_WRITE_LOCK}) { + $fh = lock_file($self->name, '>>'); + $fh->autoflush(1); + } + else { + unless ($self->{+_WPID} && $self->{+_WPID} == $$) { + delete $self->{+_WFH}; + $self->{+_WPID} = $$; + } + + if ($fh = $self->{+_WFH}) { + seek($fh, 2, 0); + } + else { + $fh = $self->{+_WFH} = Test2::Harness::Util::open_file($self->name, '>>'); + $fh->autoflush(1); + } + } + + print {$fh} $self->encode($_) for @_; + + if ($self->{+USE_WRITE_LOCK}) { + unlock_file($fh); + close($fh) or die "Could not close file '$name': $!"; + } + + return @_; +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + my $fh = $self->fh; + my $name = $self->{+NAME}; + + seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; + $self->{+LINE_POS} = $pos; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Stream - Utility class for manipulating a file that +serves as an output stream. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::File> that streams the contents of a file, even +if the file is still being written. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Stream; + + my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); + + # Read some lines + my @lines = $stream->poll; + + ... + + # Read more lines, if any. + push @lines => $stream->poll; + +=head1 ATTRIBUTES + +See L<Test2::Harness::File> for additional attributes. + +These can be passed in as construction arguments if desired. + +=over 4 + +=item $bool = $stream->use_write_lock + +=item $stream->use_write_lock($bool) + +Lock the file for every C<write()> operation. + +=item $bool = $stream->tail + +Start near the end of the file and only poll for updates appended to it. + +=back + +=head1 METHODS + +See L<Test2::Harness::File> for additional methods. + +=over 4 + +=item @lines = $stream->read() + +Read all lines from the beginning. Every time it is called it returns ALL lines. + +=item @lines = $stream->poll() + +=item @lines = $stream->poll(max => $int) + +Poll for lines. This is an iterator, it should not return the same line more +than once, you can call it multiple times to get any additional lines that have +been added since the last poll. + +=item $stream->write(@content) + +Append @content to the file. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/File/Value.pm b/libold2/Test2/Harness/Util/File/Value.pm new file mode 100644 index 000000000..bf291ba5b --- /dev/null +++ b/libold2/Test2/Harness/Util/File/Value.pm @@ -0,0 +1,100 @@ +package Test2::Harness::Util::File::Value; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + $self->{+DONE} = 1; +} + +sub read { + my $self = shift; + my $out = $self->SUPER::read(@_); + chomp($out) if defined $out; + return $out; +} + +sub read_line { + my $self = shift; + my $out = $self->SUPER::read_line(@_); + chomp($out) if defined $out; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Value - Utility class for a file that contains +exactly 1 value. + +=head1 DESCRIPTION + +This is a subclass of L<Test2::Harness::Util::File> for files expected to have +exactly 1 value stored in them. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Value; + + my $vf = Test2::Harness::Util::File::Value->new(name => 'path/to/file'); + my $val = $vf->read; + +=head1 METHODS + +=over 4 + +=item $val = $vf->read() + +Read all contents from the file, C<chomp()> it, and return it. + +=item $val = $vf->read_line() + +Read the first line from the file, C<chomp()> it, and return it. Note, this +may not return anything if the value in the file does not terminate with a +newline. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/HashBase.pm b/libold2/Test2/Harness/Util/HashBase.pm new file mode 100644 index 000000000..0146e1c7c --- /dev/null +++ b/libold2/Test2/Harness/Util/HashBase.pm @@ -0,0 +1,473 @@ +package Test2::Harness::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.008'; + *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub import { + my $class = shift; + my $into = caller; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; + $Test2::Harness::Util::HashBase::VERSION{$into} = $ver if !$Test2::Harness::Util::HashBase::VERSION{$into} || $Test2::Harness::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Harness::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Harness::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Harness::Util::HashBase>. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Harness::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B<Note:> Test2::Harness::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Harness::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'s key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Harness::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Harness::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Harness::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Harness::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Harness::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Harness::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Harness::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Harness::Util::HashBase class. + +=over 4 + +=item @list = Test2::Harness::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Harness::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/IPC.pm b/libold2/Test2/Harness/Util/IPC.pm new file mode 100644 index 000000000..d81d63abd --- /dev/null +++ b/libold2/Test2/Harness/Util/IPC.pm @@ -0,0 +1,336 @@ +package Test2::Harness::Util::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Cwd qw/getcwd/; +use Errno qw/ESRCH/; +use Config qw/%Config/; +use Test2::Util qw/CAN_REALLY_FORK/; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + USE_P_GROUPS + run_cmd + swap_io + pid_is_running +}; + +BEGIN { + if ($Config{'d_setpgrp'}) { + *USE_P_GROUPS = sub() { 1 }; + } + else { + *USE_P_GROUPS = sub() { 0 }; + } +} + +if (CAN_REALLY_FORK) { + *run_cmd = \&_run_cmd_fork; +} +else { + *run_cmd = \&_run_cmd_spwn; +} + +sub pid_is_running { + my ($pid) = @_; + + local $!; + return 1 if kill(0, $pid) || $! != ESRCH; + return 0; +} + +sub swap_io { + my ($fh, $to, $die, $mode) = @_; + + $die ||= sub { + my @caller = caller; + my @caller2 = caller(1); + die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); + }; + + my $orig_fd; + if (ref($fh) eq 'ARRAY') { + ($orig_fd, $fh) = @$fh; + } + else { + $orig_fd = fileno($fh); + } + + $die->("Could not get original fd ($fh)") unless defined $orig_fd; + + if (ref($to)) { + $mode //= $orig_fd ? '>&' : '<&'; + open($fh, $mode, $to) or $die->("Could not redirect output: $!"); + } + else { + $mode //= $orig_fd ? '>' : '<'; + open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); + } + + return if fileno($fh) == $orig_fd; + + $die->("New handle does not have the desired fd!"); +} + +sub _run_cmd_fork { + my %params = @_; + + my $cmd = $params{command} or die "No 'command' specified"; + + my $pid = fork; + die "Failed to fork" unless defined $pid; + if ($pid) { + $_->() for @{$params{run_in_parent} // []}; + return $pid; + } + else { + $_->() for @{$params{run_in_child} // []}; + } + %ENV = (%ENV, %{$params{env}}) if $params{env}; + setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp}; + + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + if (my $dir = $params{chdir} // $params{ch_dir}) { + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDERR, $stderr, $die) if $stderr; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + swap_io(\*STDIN, $stdin, $die) if $stdin; + open(STDIN, "<", "/dev/null") if !$stdin; + + @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd; + + exec(@$cmd) or $die->("Failed to exec!"); +} + +sub _run_cmd_spwn { + my %params = @_; + + local %ENV = (%ENV, %{$params{env}}) if $params{env}; + + my $cmd = $params{command} or die "No 'command' specified"; + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + my $cwd; + if (my $dir = $params{chdir} // $params{ch_dir}) { + $cwd = getcwd(); + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDIN, '<&', \*STDIN) or die "Could not clone STDIN: $!"; + open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!"; + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $stdin, $die) if $stdin; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + $stdin ? swap_io(\*STDIN, $stdin, $die) : close(STDIN); + + local $?; + my $pid; + my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd }; + my $bad = $?; + my $err = $@; + + swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die); + swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr; + swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout; + + if ($cwd) { + chdir($cwd) or die "Could not chdir: $!"; + } + + die $err unless $ok; + die "Spawn resulted in code $bad" if $bad && $bad != $pid; + die "Failed to spawn" unless $pid; + + $_->() for @{$params{run_in_parent} // []}; + + return $pid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::IPC - Utilities for IPC management. + +=head1 DESCRIPTION + +This package provides low-level IPC tools for Test2::Harness. + +=head1 EXPORTS + +All exports are optional and must be specified at import time. + +=over 4 + +=item $bool = USE_P_GROUPS() + +This is a shortcut for: + + use Config qw/%Config/; + $Config{'d_setpgrp'}; + +=item swap_io($from, $to) + +=item swap_io($from, $to, \&die) + +This will close and re-open the file handle designated by C<$from> so that it +redirects to the handle specified in C<$to>. It preserves the file descriptor +in the process, and throws an exception if it fails to do so. + + swap_io(\*STDOUT, $fh); + # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'. + +As long as the file descriptor is greater than 0 it will open for writing. If +the descriptor is 0 it will open for reading, allowing for a swap of C<STDIN> +as well. + +Extra effort is made to insure errors go to the real C<STDERR>, specially when +trying to swap out C<STDERR>. If you have trouble with this, or do not trust +it, you can provide a custom coderef as a third argument, this coderef will be +used instead of C<die()> to throw exceptions. + +Note that the custom die logic when you do not provide your own bypasses the +exception catching mechanism and will exit your program. If this is not +desirable then you should provide a custom die subref. + +=item $pid = run_cmd(command => [...], %params) + +This function will run the specified command and return a pid to you. When +possible this will be done via C<fork()> and C<exec()>. When that is not +possible it uses the C<system(1, ...)> trick to spawn a new process. Some +parameters do not work in the second case, and are silently ignored. + +Parameters: + +=over 4 + +=item command => [$command, sub { ... }, @args] + +=item command => sub { return ($command, @args) } + +This parameter is required. This should either be an arrayref of arguments for +C<exec()>, or a coderef that returns a list of arguments for C<exec()>. On +systems without fork/exec the arguments will be passed to +C<system(1, $command, @args)> instead. + +If the command arrayref has a coderef in it, the coderef will be run and its +return value(s) will be inserted in its place. This replacement happens +post-chroot + +=item run_in_parent => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the parent process immedietly after the +child process is started. + +=item run_in_child => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the child process immedietly after fork. +This parameter is silently ignored on systems without fork/exec. + +=item env => { ENVVAR => $VAL, ... } + +A hashref of custom environment variables to set in the child process. In the +fork/exec model this is done post-fork, in the spawn model this is done via +local prior to the spawn. + +=item no_set_pgrp => $bool, + +Normall C<setpgrp(0,0)> is called on systems where it is supported. You can use +this parameter to override the normal behavior. setpgrp() is not called in the +spawn model, so this parameter is silently ignored there. + +=item chdir => 'path/to/dir' + +=item ch_dir => 'path/to/dir' + +chdir() to the specified directory for the new process. In the fork/exec model +this is done post-fork in the child. In the spawn model this is done before the +spawn, then a second chdir() puts the parent process back to its original dir +after the spawn. + +=item stdout => $handle + +=item stderr => $handle + +=item stdin => $handle + +Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec +model these are swapped into place post-fork in the child. In the spawn model +the swap occurs pre-spawn, then the old handles are swapped back post-spawn. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/JSON.pm b/libold2/Test2/Harness/Util/JSON.pm new file mode 100644 index 000000000..2c73ec443 --- /dev/null +++ b/libold2/Test2/Harness/Util/JSON.pm @@ -0,0 +1,263 @@ +package Test2::Harness::Util::JSON; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +BEGIN { + local $@ = undef; + my $ok = eval { + require JSON::MaybeXS; + JSON::MaybeXS->import('JSON'); + 1; + + if (JSON() eq 'JSON::PP') { + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + elsif (JSON() eq 'JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 1 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + elsif (JSON() eq 'Cpanel::JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 1 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + }; + + unless ($ok) { + require JSON::PP; + *JSON = sub() { 'JSON::PP' }; + + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + +} + +our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; +our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); +my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); + +sub encode_json { $json->encode(@_) } +sub encode_canon_json { $canon->encode(@_) } +sub encode_pretty_json { $pretty->encode(@_) } + +sub decode_json { + my ($input) = @_; + my $data; + + local $@; + my $error; + + # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally + # testing bytes behavior we need to accept the bytes from the JSON file instead. + my $ok = eval { $data = $json->decode($input); 1 } || do { + $error = $@; + eval { $data = $json_non_utf8->decode($input); 1 }; + }; + $error ||= $@; + return $data if $ok; + my $mess = Carp::longmess("JSON decode error: $error"); + die "$mess\n=======\n$input\n=======\n"; +} + +sub stream_json_l { + my ($path, $handler, %params) = @_; + + croak "No path provided" unless $path; + + return stream_json_l_file($path, $handler) if -f $path; + return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; + + croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; +} + +sub stream_json_l_file { + my ($path, $handler) = @_; + + croak "Invalid file '$path'" unless -f $path; + + croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." + unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; + + if ($1 eq 'json') { + require Test2::Harness::Util::File::JSON; + my $json = Test2::Harness::Util::File::JSON->new(name => $path); + $handler->($json->read); + } + else { + require Test2::Harness::Util::File::JSONL; + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); + while (my ($item) = $jsonl->poll(max => 1)) { + $handler->($item); + } + } + + return 1; +} + +sub stream_json_l_url { + my ($path, $handler, %params) = @_; + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args} // []; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + my $buffer = ''; + my $iterate = sub { + my ($res) = @_; + + my @parts = split /(\n)/, $buffer; + + while (@parts > 1) { + my $line = shift @parts; + my $nl = shift @parts; + my $data; + unless (eval { $data = decode_json($line); 1 }) { + warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; + next; + } + + $handler->($data, $res); + } + + $buffer = shift @parts // ''; + }; + + my $res = $ht->$meth( + $path, + { + @$args, + data_callback => sub { + my ($chunk, $res) = @_; + $buffer .= $chunk; + $iterate->($res); + }, + } + ); + + if (length($buffer)) { + $buffer .= "\n" unless $buffer =~ m/\n$/; + $iterate->($res); + } + + return $res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best +JSON implementation. + +=head1 DESCRIPTION + +This package provides functions for encoding/decoding json, and uses the best +json tools available. + +=head1 SYNOPSIS + + use Test2::Harness::Util::JSON qw/encode_json decode_json/; + + my $data = { foo => 1 }; + my $json = encode_json($data); + my $copy = decode_json($json); + +=head1 EXPORTS + +=over 4 + +=item $package = JSON() + +This returns the JSON package being used by yath. + +=item $bool = JSON_IS_PP() + +True if yath is using L<JSON::PP>. + +=item $bool = JSON_IS_XS() + +True if yath is using L<JSON::XS>. + +=item $bool = JSON_IS_CPANEL() + +True if yath is using L<Cpanel::JSON::XS>. + +=item $bool = JSON_IS_CPANEL_OR_XS() + +True if either L<JSON::XS> or L<Cpanel::JSON::XS> are being used. + +=item $string = encode_json($data) + +Encode data into json. String will be 1-line. + +=item $data = decode_json($string) + +Decode json data from the string. + +=item $string = encode_pretty_json($data) + +Encode into human-friendly json. + +=item $string = encode_canon_json($data) + +Encode into canon-json. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/Queue.pm b/libold2/Test2/Harness/Util/Queue.pm new file mode 100644 index 000000000..efe7289b3 --- /dev/null +++ b/libold2/Test2/Harness/Util/Queue.pm @@ -0,0 +1,213 @@ +package Test2::Harness::Util::Queue; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/write_file_atomic/; + +use Test2::Harness::Util::File::JSONL(); + +use Test2::Harness::Util::HashBase qw{ + -file -qh -ended +}; + +sub init { + my $self = shift; + + croak "'file' is a required attribute" + unless $self->{+FILE}; +} + +sub start { + my $self = shift; + write_file_atomic($self->{+FILE}, ""); +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + $self->{+QH}->seek($pos); + + return $pos; +} + +sub reset { + my $self = shift; + delete $self->{+QH}; +} + +sub poll { + my $self = shift; + my $max = shift; + + return $self->{+ENDED} if $self->{+ENDED}; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + my @out = $self->{+QH}->poll_with_index( $max ? (max => $max) : () ); + + $self->{+ENDED} = $out[-1] if @out && !defined($out[-1]->[-1]); + + return @out; +} + +sub end { + my $self = shift; + $self->_enqueue(undef); +} + +sub enqueue { + my $self = shift; + my ($task) = @_; + + croak "Invalid task" + unless $task && ref($task) eq 'HASH' && values %$task; + + $task->{stamp} ||= time; + + $self->_enqueue($task); +} + +sub _enqueue { + my $self = shift; + my ($task) = @_; + + my $fh = Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}, use_write_lock => 1); + $fh->write($task); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Queue - Representation of a queue. + +=head1 DESCRIPTION + +This module represents a queue, stored as a jsonl file. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + $queue->start(); # Create the queue + + $queue->enqueue({foo => 'bar', baz => 'bat'}); + $queue->enqueue({foo => 'bar2', baz => 'bat2'}); + ... + + $queue->end(); + +Then in another processs: + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + my @items; + while (1) { + @items = $queue->poll(); + while (@items) { + my $item = shift @items or last; + + ... process $item + } + + # Queue ends with an 'undef' entry + last if @items && !defined($items[0]); + } + +=head1 METHODS + +=over 4 + +=item $path = $queue->file + +The filename used for the queue + +=back + +=head2 READING + +=over 4 + +=item $queue->reset() + +Restart reading the queue. + +=item @items = $queue->poll() + +Get more items from the queue. May need to call it multiple times, specially if +another process is still writing to the queue. + +Returns an empty list if no items are available yet. + +Returns 'undef' to terminate the list. + +=item $bool = $queue->ended() + +Check if the queue has ended. + +=back + +=head1 WRITING + +=over 4 + +=item $queue->start() + +Open the queue file for writing. + +=item $queue->enqueue(\%HASHREF) + +Add an item to the queue. + +=item $queue->end() + +Terminate the queue. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/Term.pm b/libold2/Test2/Harness/Util/Term.pm new file mode 100644 index 000000000..da0b6a306 --- /dev/null +++ b/libold2/Test2/Harness/Util/Term.pm @@ -0,0 +1,104 @@ +package Test2::Harness::Util::Term; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; + +use Importer Importer => 'import'; +our @EXPORT_OK = qw/USE_ANSI_COLOR/; + +{ + my $use = 0; + local ($@, $!); + + if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { + if (IS_WIN32) { + if (eval { require Win32::Console::ANSI }) { + Win32::Console::ANSI->import(); + $use = 1; + } + } + else { + $use = 1; + } + } + + if ($use) { + *USE_ANSI_COLOR = sub() { 1 }; + } + else { + *USE_ANSI_COLOR = sub() { 0 }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Term - Terminal utilities for Test2::Harness + +=head1 DESCRIPTION + +This module provides information about the terminal in which the harness is +running. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + + if (USE_ANSI_COLOR) { + ... + } + else { + ... + } + +=head1 EXPORTS + +=over 4 + +=item $bool = USE_ANSI_COLOR() + +True if L<Term::ANSIColor> is available and usable. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Harness/Util/UUID.pm b/libold2/Test2/Harness/Util/UUID.pm new file mode 100644 index 000000000..459bea92e --- /dev/null +++ b/libold2/Test2/Harness/Util/UUID.pm @@ -0,0 +1,85 @@ +package Test2::Harness::Util::UUID; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Data::UUID; +use Importer 'Importer' => 'import'; + +our @EXPORT = qw/gen_uuid/; +our @EXPORT_OK = qw/UG gen_uuid/; + +my ($UG, $UG_PID); +sub UG { + return $UG if $UG && $UG_PID && $UG_PID == $$; + + $UG_PID = $$; + return $UG = Data::UUID->new; +} + +sub gen_uuid { UG()->create_str() } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::UUID - Utils for generating UUIDs. + +=head1 DESCRIPTION + +This module provides a consistent UUID source for all of Test2::Harness. + +=head1 SYNOPSIS + + use Test2::Harness::Util::UUID qw/gen_uuid/; + + my $uuid = gen_uuid; + +=head1 EXPORTS + +=over 4 + +=item $uuid = gen_uuid() + +Generate a UUID. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libold2/Test2/Tools/HarnessTester.pm b/libold2/Test2/Tools/HarnessTester.pm new file mode 100644 index 000000000..e48090390 --- /dev/null +++ b/libold2/Test2/Tools/HarnessTester.pm @@ -0,0 +1,179 @@ +package Test2::Tools::HarnessTester; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Tester qw/make_example_dir/; + +use Importer Importer => qw/import/; +our @EXPORT_OK = qw/make_example_dir summarize_events/; + +my $HARNESS_ID = 1; +sub summarize_events { + my ($events) = @_; + + my @caller = caller(0); + + my $id = $HARNESS_ID++; + my $run_id = "run-$id"; + my $job_id = "job-$id"; + + require Test2::Harness::Auditor::Watcher; + my $watcher = Test2::Harness::Auditor::Watcher->new(job => 1, try => 0); + + require Test2::Harness::Event; + for my $e (@$events) { + my $fd = $e->facet_data; + my $he = Test2::Harness::Event->new( + facet_data => $fd, + event_id => gen_uuid(), + run_id => $run_id, + job_id => $job_id, + stamp => time, + job_try => 0, + ); + + $watcher->process($he); + } + + return { + plan => $watcher->plan, + pass => $watcher->pass ? 1 : 0, + fail => $watcher->fail ? 1 : 0, + errors => $watcher->_errors, + failures => $watcher->_failures, + assertions => $watcher->assertion_count, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::HarnessTester - Run events through a harness for a summary + +=head1 DESCRIPTION + +This tool allows you to process events through the L<Test2::Harness> auditor. +The main benefit here is to get a pass/fail result, as well as counts for +assertions, failures, and errors. + +=head1 SYNOPSIS + + use Test2::V0; + use Test2::API qw/intercept/; + use Test2::Tools::HarnessTester qw/summarize_events/; + + my $events = intercept { + ok(1, "pass"); + ok(2, "pass gain"); + done_testing; + }; + + is( + summarize_events($events), + { + # Each of these is the negation of the other, no need to check both + pass => 1, + fail => 0, + + # The plan facet, see Test2::EventFacet::Plan + plan => {count => 2}, + + # Statistics + assertions => 2, + errors => 0, + failures => 0, + } + ); + +=head1 EXPORTS + +=head2 $summary = summarize_events($events) + +This takes an arrayref of events, such as that produced by C<intercept {...}> +from L<Test2::API>. The result is a hashref that summarizes the results of the +events as processed by L<Test2::Harness>, specifically the +L<Test2::Harness::Auditor::Watcher> module. + +Fields in the summary hash: + +=over 4 + +=item pass => $BOOL + +=item fail => $BOOL + +These are negatives of eachother. These represent the pass/fail state after +processing the events. When one is true the other should be false. These are +normalized to C<1> and C<0>. + +=item plan => $HASHREF + +If a plan was provided this will have the L<Test2::EventFacet::Plan> facet, but +as a hashref, not a blessed instance. + +B<Note:> This is reference to the original data, not a copy, if you modify it +you will modify the event as well. + +=item assertions => $INT + +Count of assertions made. + +=item errors => $INT + +Count of errors seen. + +=item failures => $INT + +Count of failures seen. + +=back + +=head2 $path = make_example_dir() + +This will create a temporary directory with 't', 't2', and 'xt' subdirectories +each of which will contain a single passing test. + +This is re-exported from L<App::Yath::Tester>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Formatter/Test2.pm b/libx/Test2/Formatter/Test2.pm new file mode 100644 index 000000000..c2d44fa85 --- /dev/null +++ b/libx/Test2/Formatter/Test2.pm @@ -0,0 +1,804 @@ +package Test2::Formatter::Test2; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Term qw/term_size/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; +use Test2::Util qw/IS_WIN32 clone_io/; +use Time::HiRes qw/time/; +use IO::Handle; + +use File::Spec(); +use Test2::Formatter::Test2::Composer; + +use parent 'Test2::Formatter'; + +sub import { + my $class = shift; + return if $ENV{HARNESS_ACTIVE}; + $class->SUPER::import; +} + +use Test2::Util::HashBase qw{ + -composer + -last_depth + -_buffered + <job_io + +io + <enc_io + -_encoding + -show_buffer + -color + -progress + -tty + -no_wrap + -verbose + -job_length + -ecount + -job_colors + -active_files + -_active_disp + -_file_stats + -job_names + -is_persistent + -interactive +}; + +sub TAG_WIDTH() { 8 } + +sub hide_buffered() { 0 } + +sub DEFAULT_TAG_COLOR() { + return ( + 'DEBUG' => Term::ANSIColor::color('red'), + 'DIAG' => Term::ANSIColor::color('yellow'), + 'ERROR' => Term::ANSIColor::color('red'), + 'FATAL' => Term::ANSIColor::color('bold red'), + 'FAIL' => Term::ANSIColor::color('red'), + 'HALT' => Term::ANSIColor::color('bold red'), + 'PASS' => Term::ANSIColor::color('green'), + '! PASS !' => Term::ANSIColor::color('cyan'), + 'TODO' => Term::ANSIColor::color('cyan'), + 'NO PLAN' => Term::ANSIColor::color('yellow'), + 'SKIP' => Term::ANSIColor::color('bold cyan'), + 'SKIP ALL' => Term::ANSIColor::color('bold white on_blue'), + 'STDERR' => Term::ANSIColor::color('yellow'), + 'RUN INFO' => Term::ANSIColor::color('bold bright_blue'), + 'JOB INFO' => Term::ANSIColor::color('bold bright_blue'), + 'LAUNCH' => Term::ANSIColor::color('bold bright_white'), + 'RETRY' => Term::ANSIColor::color('bold bright_white'), + 'PASSED' => Term::ANSIColor::color('bold bright_green'), + 'TO RETRY' => Term::ANSIColor::color('bold bright_yellow'), + 'FAILED' => Term::ANSIColor::color('bold bright_red'), + 'REASON' => Term::ANSIColor::color('magenta'), + 'TIMEOUT' => Term::ANSIColor::color('magenta'), + 'TIME' => Term::ANSIColor::color('blue'), + 'MEMORY' => Term::ANSIColor::color('blue'), + ); +} + +sub DEFAULT_FACET_COLOR() { + return ( + time => Term::ANSIColor::color('blue'), + memory => Term::ANSIColor::color('blue'), + about => Term::ANSIColor::color('magenta'), + amnesty => Term::ANSIColor::color('cyan'), + assert => Term::ANSIColor::color('bold bright_white'), + control => Term::ANSIColor::color('bold red'), + error => Term::ANSIColor::color('yellow'), + info => Term::ANSIColor::color('yellow'), + meta => Term::ANSIColor::color('magenta'), + parent => Term::ANSIColor::color('magenta'), + trace => Term::ANSIColor::color('bold red'), + ); +} + +# These colors all look decent enough to use, ordered to avoid putting similar ones together +use constant DEFAULT_JOB_COLOR_NAMES => ( + 'bold green on_blue', + 'bold blue on_white', + 'bold black on_cyan', + 'bold green on_bright_black', + 'bold dark blue on_white', + 'bold black on_green', + 'bold cyan on_blue', + 'bold black on_white', + 'bold white on_cyan', + 'bold cyan on_bright_black', + 'bold white on_green', + 'bold bright_black on_white', + 'bold white on_blue', + 'bold bright_cyan on_green', + 'bold blue on_cyan', + 'bold white on_bright_black', + 'bold bright_black on_green', + 'bold bright_green on_blue', + 'bold bright_blue on_white', + 'bold bright_white on_bright_black', + 'bold yellow on_blue', + 'bold bright_black on_cyan', + 'bold bright_green on_bright_black', + 'bold blue on_green', + 'bold bright_cyan on_blue', + 'bold bright_blue on_cyan', + 'bold dark bright_white on_bright_black', + 'bold bright_blue on_green', + 'bold dark bright_blue on_white', + 'bold bright_white on_blue', + 'bold bright_cyan on_bright_black', + 'bold bright_white on_cyan', + 'bold bright_white on_green', + 'bold bright_yellow on_blue', + #'bold magenta on_white', + #'bold dark magenta on_white', + #'bold dark cyan on_white', + 'bold dark bright_cyan on_bright_black', + #'bold dark bright_green on_black', + #'bold dark bright_yellow on_black', +); + +sub DEFAULT_JOB_COLOR() { + return map { Term::ANSIColor::color($_) } DEFAULT_JOB_COLOR_NAMES; +} + +sub DEFAULT_COLOR() { + return ( + reset => Term::ANSIColor::color('reset'), + blob => Term::ANSIColor::color('bold bright_black on_white'), + tree => Term::ANSIColor::color('bold bright_white'), + tag_border => Term::ANSIColor::color('bold bright_white'), + ); +} + +my %FACET_TAG_BORDERS = ( + 'default' => ['[', ']'], + 'amnesty' => ['{', '}'], + 'info' => ['(', ')'], + 'error' => ['<', '>'], + 'parent' => [' ', ' '], +); + +sub init { + my $self = shift; + + $self->{+COMPOSER} ||= Test2::Formatter::Test2::Composer->new; + + $self->{+VERBOSE} = 1 unless defined $self->{+VERBOSE}; + + $self->{+JOB_LENGTH} ||= 2; + + my $io = $self->{+IO} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + + $self->{+TTY} = -t $io unless defined $self->{+TTY}; + + my $use_color = ref($self->{+COLOR}) ? 1 : delete($self->{+COLOR}); + $use_color = $self->{+TTY} unless defined $use_color; + + if ($use_color && USE_ANSI_COLOR) { + $self->{+SHOW_BUFFER} = 1 unless defined $self->{+SHOW_BUFFER}; + + if ($use_color) { + $self->{+COLOR} = { + DEFAULT_COLOR(), + TAGS => {DEFAULT_TAG_COLOR()}, + FACETS => {DEFAULT_FACET_COLOR()}, + JOBS => [DEFAULT_JOB_COLOR()], + } unless defined $self->{+COLOR}; + + $self->{+JOB_COLORS} = {free => [@{$self->{+COLOR}->{JOBS}}]}; + } + } + else { + $self->{+SHOW_BUFFER} = 0 unless defined $self->{+SHOW_BUFFER}; + } + + $self->{+ECOUNT} //= 0; + + my $reset = $use_color ? Term::ANSIColor::color('reset') : ''; + my $cyan = $use_color ? Term::ANSIColor::color('cyan') : ''; + $self->{+_ACTIVE_DISP} = ["[${cyan}INITIALIZING${reset}]", '']; + $self->{+_FILE_STATS} = { + passed => 0, + failed => 0, + running => 0, + todo => 0, + total => 0, + }; + + +} + +sub io { + my $self = shift; + my ($job_id) = @_; + return $self->{+IO} unless defined $job_id; + return $self->{+JOB_IO}->{$job_id} // $self->{+IO}; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc, $job_id) = @_; + if (defined $job_id) { + my $io; + + unless ($io = $self->{+ENC_IO}->{$enc}) { + $io = $self->{+ENC_IO}->{$enc} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + apply_encoding($io, $enc); + } + + $self->{+JOB_IO}->{$job_id} = $io; + } + else { + apply_encoding($self->{+IO}, $enc); + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + my $should_show = $self->update_active_disp($f); + + $self->{+ECOUNT}++; + + my $job_id = $f->{harness}->{job_id}; + $self->encoding($f->{control}->{encoding}, $job_id) if $f->{control}->{encoding}; + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + return if $depth && (!$self->{+SHOW_BUFFER} || !$self->{+PROGRESS}); + + my $lines; + if (!$self->{+VERBOSE}) { + if ($depth) { + $lines = []; + } + else { + $lines = $self->render_quiet($f); + } + } + elsif ($depth) { + my $tree = $self->render_tree($f, '>'); + $lines = $self->render_buffered_event($f, $tree); + } + else { + my $tree = $self->render_tree($f,); + $lines = $self->render_event($f, $tree); + } + + $should_show ||= $lines && @$lines; + unless ($should_show || $self->{+VERBOSE}) { + if (my $last = $self->{last_rendered}) { + return if time - $last < 0.2; + $self->{last_rendered} = time; + } + else { + $self->{last_rendered} = time; + } + } + + push @{$self->{+JOB_COLORS}->{free}} => delete $self->{+JOB_COLORS}->{used}->{$job_id} + if $job_id && $f->{harness_job_end}; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->io($job_id); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if (!$self->{+VERBOSE}) { + print $io $_, "\n" for @$lines; + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + } + elsif ($depth && $lines && @$lines && !$self->{+INTERACTIVE}) { + print $io $lines->[0]; + $self->{+_BUFFERED} = 1; + } + else { + print $io $_, "\n" for @$lines; + } + + delete $self->{+JOB_IO}->{$job_id} if $job_id && $f->{harness_job_end}; +} + +sub finalize { + my $self = shift; + + my $io = $self->{+IO}; + print $io "\r\e[K" if $self->{+_BUFFERED}; + + return; +} + +sub step { + my $self = shift; + + return unless $self->update_active_disp; + + my $io = $self->io(0); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status(); + $self->{+_BUFFERED} = 1; + } +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + my $should_show = 0; + + my $stats = $self->{+_FILE_STATS}; + + my $out = 0; + $out = $self->update_spinner($stats) unless $stats->{started}; + + return $out unless $f; + + if (my $task = $f->{harness_job_queued}) { + $self->{+JOB_NAMES}->{$task->{job_id}} = $task->{job_name} || $task->{job_id}; + $stats->{total}++; + $stats->{todo}++; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($job->{file})} = $job->{job_name} || $job->{job_id}; + $should_show = 1; + $stats->{running}++; + $stats->{todo}--; + $stats->{started} //= 1; + } + + if ($f->{harness_job_end}) { + my $file = $f->{harness_job_end}->{file}; + delete $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($file)}; + $should_show = 1; + $stats->{running}--; + + if ($f->{harness_job_end}->{fail}) { + $stats->{failed}++; + } + else { + $stats->{passed}++; + } + } + + return $out unless $should_show; + + my $statline = join '|' => ( + $self->_highlight($stats->{passed}, 'P', 'green'), + $self->_highlight($stats->{failed}, 'F', 'red'), + $self->_highlight($stats->{running}, 'R', 'cyan'), + $self->_highlight($stats->{todo}, 'T', 'yellow'), + ); + + $statline = "[$statline]"; + + my $active = $self->{+ACTIVE_FILES}; + + return $self->{+_ACTIVE_DISP} = [$statline, ''] unless $active && keys %$active; + + my $reset = $self->reset; + + my $str .= "("; + { + no warnings 'numeric'; + $str .= join(' ' => map { m{([^/]+)$}; "$active->{$_}:$1" } sort { ($active->{$a} || 0) <=> ($active->{$b} || 0) or $a cmp $b } keys %$active); + } + $str .= ")"; + + $self->{+_ACTIVE_DISP} = [$statline, $str]; + + return 1; +} + +sub update_spinner { + my $self = shift; + my ($stats) = @_; + + $stats->{spinner} //= '|'; + $stats->{spinner_time} //= time - 1; + $stats->{blink_time} //= time - 1; + $stats->{blink} //= ''; + + if (time - $stats->{spinner_time} > 0.1) { + $stats->{spinner_time} = time; + my $start = substr($stats->{spinner}, 0, 1); + $stats->{spinner} = '\\' if $start eq '-'; + $stats->{spinner} = '-' if $start eq '/'; + $stats->{spinner} = '/' if $start eq '|'; + $stats->{spinner} = '|' if $start eq '\\'; + } + elsif(time - $stats->{blink_time} > 0.5) { + $stats->{blink_time} = time; + $stats->{blink} = $stats->{blink} ? '' : 'bold bright_'; + } + else { + return 0; + } + + my $yellow = $self->{+COLOR} ? Term::ANSIColor::color($stats->{blink} . 'yellow') : ''; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + my $green = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_green') : ''; + my $bold = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_white') : ''; + my $reset = $self->reset; + + $self->{+_ACTIVE_DISP} = [ + join( + '' => ( + $bold => "[ ", $reset, + $green => $stats->{spinner}, $reset, + '' => " ", + $self->{+IS_PERSISTENT} + ? ( + $yellow => "Waiting for busy runner", $reset, + '' => " ", + $reset => "(see ", $reset, + $cyan => "yath status", $reset, + $reset => ")", $reset, + ) + : ($yellow => "INITIALIZING", $reset), + '' => " ", + $green => $stats->{spinner}, $reset, + $bold => " ]", $reset, + ) + ), + '', + ]; + + return 1; +} + +sub _highlight { + my $self = shift; + my ($val, $label, $color) = @_; + + return "${label}:${val}" unless $val && $self->{+COLOR}; + return sprintf('%s%s:%d%s', Term::ANSIColor::color($color), $label, $val, $self->reset); +} + + +sub colorstrip { + my $self = shift; + my ($str) = @_; + + return $str unless USE_ANSI_COLOR; + return Term::ANSIColor::colorstrip($str); +} + +sub render_status { + my $self = shift; + + my $reset = $self->reset; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + + my $str = "$self->{+_ACTIVE_DISP}->[0] Events: $self->{+ECOUNT} ${cyan}$self->{+_ACTIVE_DISP}->[1]${reset}"; + + my $max = term_size() || 80; + + if (length($str) > $max) { + my $nocolor = $self->colorstrip($str); + $str = substr($nocolor, 0, $max - 8) . " ...)$reset" if length($nocolor) > $max; + $str =~ s/\(/$cyan(/; + $str =~ s/^\[[^\]]+\]/$self->{+_ACTIVE_DISP}->[0]/; + } + + return $str; +} + +sub render_buffered_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comp = $self->{+COMPOSER}->render_one_line($f) or return; + + return unless @$comp; + return [$self->build_line($tree, @$comp)]; +} + +sub render_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comps = $self->{+COMPOSER}->render_verbose($f); + + my (@parent, @times); + + if ($f->{parent}) { + @parent = $self->render_parent($f, $tree); + + if (@$comps && $comps->[-1]->[0] eq 'times') { + my $times = pop(@$comps); + @times = $self->build_line($tree, @$times); + } + } + + my @out; + + for my $comp (@$comps) { + my $ctree = $tree; + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + push @out => (@parent, @times); + + return \@out; +} + +sub render_quiet { + my $self = shift; + my ($f, $tree) = @_; + + my @out; + + my $comps = $self->{+COMPOSER}->render_brief($f); + for my $comp (@$comps) { + my $ctree = $tree ||= $self->render_tree($f); + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + if ($f->{parent} && !$f->{amnesty}) { + push @out => $self->render_parent($f, $tree ||= $self->render_tree($f), quiet => 1); + } + + return \@out; +} + +sub reset { + my $self = shift; + return $self->{+COLOR} ? $self->{+COLOR}->{reset} : ''; +} + +sub job_color { + my $self = shift; + my ($id, $set) = @_; + return '' unless $self->{+JOB_COLORS}; + return $self->{+JOB_COLORS}->{used}->{$id} || '' unless $set; + return $self->{+JOB_COLORS}->{used}->{$id} ||= shift @{$self->{+JOB_COLORS}->{free}} || ''; +} + +sub render_tree { + my $self = shift; + my ($f, $char) = @_; + $char ||= '|'; + + my $job = ''; + if ($f->{harness} && $f->{harness}->{job_id}) { + my $id = $f->{harness}->{job_id}; + my $name = $self->{+JOB_NAMES}->{$id}; + + my ($color, $reset) = ('', ''); + if ($self->{+JOB_COLORS}) { + $color = $self->job_color($id, 'set'); + $reset = $self->reset; + } + + my $len = length($name); + if (!$self->{+JOB_LENGTH} || $len > $self->{+JOB_LENGTH}) { + $self->{+JOB_LENGTH} = $len; + } + else { + $len = $self->{+JOB_LENGTH}; + } + + $job = sprintf("%sjob %${len}s%s ", $color, $name, $reset || ''); + } + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + my @pipes = (' ', map $char, 1 .. $depth); + return join(' ' => $job, @pipes) . ' '; +} + +sub build_line { + my $self = shift; + my ($tree, $facet, $tag, $text) = @_; + + $tree ||= ''; + $tag ||= ''; + $text ||= ''; + chomp($text); + + substr($tree, -2, 1, '+') if $facet eq 'assert'; + + $tag = substr($tag, 0 - TAG_WIDTH, TAG_WIDTH) if length($tag) > TAG_WIDTH; + + my $max = $self->{+TTY} && !$self->{+NO_WRAP} ? (term_size() || 80) : undef; + my $color = $self->{+COLOR}; + my $reset = $self->reset; + my $tcolor = $color ? $color->{TAGS}->{$tag} || $color->{FACETS}->{$facet} || '' : ''; + + my ($ps, $pe) = @{$FACET_TAG_BORDERS{$facet} || $FACET_TAG_BORDERS{default}}; + + $tag = uc($tag); + my $length = length($tag); + if ($length > TAG_WIDTH) { + $tag = substr($tag, 0, TAG_WIDTH); + } + elsif($length < TAG_WIDTH) { + my $pad = (TAG_WIDTH - $length) / 2; + my $padl = $pad + (TAG_WIDTH - $length) % 2; + $tag = (' ' x $padl) . $tag . (' ' x $pad); + } + + my $start; + if ($color) { + my $border = $color->{tag_border} || ''; + $start = "${reset}${border}${ps}${reset}${tcolor}${tag}${reset}${border}${pe}${reset}"; + } + else { + $start = "${ps}${tag}${pe}"; + } + $start .= " "; + + if ($tree) { + if ($color) { + my $trcolor = $color->{tree} || ''; + $start .= $trcolor . $tree . $reset; + } + else { + $start .= $tree; + } + } + + my @lines = split /[\r\n]/, $text; + @lines = ($text) unless @lines; + + my @out; + for my $line (@lines) { + if(@lines > 1 && $max && length("$ps$tag$pe $tree$line") > $max) { + @out = (); + last; + } + + if ($color) { + push @out => "${start}${tcolor}${line}$reset"; + } + else { + push @out => "${start}${line}"; + } + } + + return @out if @out; + + return ( + "$start----- START -----", + $text, + "$start------ END ------", + ) unless $color; + + my $blob = $color->{blob} || ''; + return ( + "$start${blob}----- START -----$reset", + "${tcolor}${text}${reset}", + "$start${blob}------ END ------$reset", + ); +} + +sub render_parent { + my $self = shift; + my ($f, $tree, %params) = @_; + + my $meth = $params{quiet} ? 'render_quiet' : 'render_event'; + + my @out; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness} ||= $f->{harness}; + my $tree = $self->render_tree($sf); + push @out => @{$self->$meth($sf, $tree)}; + } + + return unless @out; + + push @out => ( + $self->build_line("$tree^", 'parent', '', ''), + ); + + return @out; +} + + +sub DESTROY { + my $self = shift; + + my $io = $self->{+IO} or return; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + print $io Term::ANSIColor::color('reset') + if USE_ANSI_COLOR; + + print $io "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2 - An alternative to TAP, used by Test2::Harness. + +=head1 DESCRIPTION + +This formatter is the primary formatter used for final result rendering when +you use Test2::Harness. This formatter is NOT designed to have its output +consumed by code/machine/harnesses. The goal of this formatter is to have +output that is easily read by humans. + +=head1 SYNOPSIS + +If you are running a test directly with perl and want to use this formatter: + + $ perl -MTest2::Formatter::Test2 path/to/test.t + +You could also use the module directly in your test, but that is not +recommended as your test would then be unable to be run via prove or other +harnesses. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Formatter/Test2/Composer.pm b/libx/Test2/Formatter/Test2/Composer.pm new file mode 100644 index 000000000..d6b642d19 --- /dev/null +++ b/libx/Test2/Formatter/Test2/Composer.pm @@ -0,0 +1,507 @@ +package Test2::Formatter::Test2::Composer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use List::Util qw/first/; + +sub new { + my $class = shift; + return bless({}, $class); +} + +sub render_one_line { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + return [$f->{render}->[0]->{facet}, uc($f->{render}->[0]->{tag}), $f->{render}->[0]->{details}] + if $f->{render} && @{$f->{render}}; + + return (($class->halt($f))[0]) if $class->{control} && defined $class->{control}->{halt}; + + for my $type (qw/assert errors plan info times about/) { + next unless $f->{$type}; + my $m = "render_$type"; + my ($out) = $class->$m($f); + return $out if defined $out; + } + + return; +} + +sub render_verbose { + my $class = shift; + my ($in, %params) = @_; + + my $f = blessed($in) ? $in->facet_data : $in; + + return [map {[$_->{facet}, uc($_->{tag}), $_->{details}]} @{$f->{render}}] + if $f->{render} && @{$f->{render}}; + + my @out; + + push @out => $class->render_control($f, %params) if $f->{control}; + push @out => $class->render_plan($f) if $f->{plan}; + + if ($f->{assert}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{pass} || $f->{assert}->{no_debug}; + push @out => $class->render_amnesty($f) if $f->{amnesty} && @{$f->{amnesty}}; + } + + push @out => $class->render_info($f) if $f->{info}; + push @out => $class->render_errors($f) if $f->{errors}; + + push @out => $class->render_about($f) + if $f->{about} && !(@out || first { $f->{$_} } qw/stop plan info nest assert/); + + return \@out; +} + +sub render_super_verbose { + my $class = shift; + my ($in) = @_; + + my $out = $class->render_verbose($in, super_verbose => 1); + + my $f = blessed($in) ? $in->facet_data : $in; + + push @$out => $class->render_launch($f) if $f->{harness_job_launch}; + push @$out => $class->render_start($f) if $f->{harness_job_start}; + push @$out => $class->render_exit($f) if $f->{harness_job_exit}; + push @$out => $class->render_end($f) if $f->{harness_job_end}; + + unless (@$out) { + my ($name, $fallback); + for my $k (sort keys %$f) { + my $v = $f->{$k}; + + # Fallback should be longest harness* facet name + $fallback = $k if $k =~ m/harness/ && (!$fallback || length($fallback) < length($k)); + + my $list = ref($v) eq 'ARRAY' ? $v : [$v]; + for my $i (@$list) { + next unless ref($i); + last if $name = $i->{details}; + } + } + + $name //= $fallback // join ', ' => sort keys %$f; + + push @$out => ['harness', 'HARNESS', $name]; + } + + return $out; +} + +sub render_launch { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', 'Job Launched at ' . $f->{harness_job_launch}->{stamp}]; +} + +sub render_start { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_start}->{details}]; +} + +sub render_exit { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_exit}->{details}]; +} + +sub render_end { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', "Job completed at " . $f->{harness_job_end}->{stamp}]; +} + +sub render_control { + my $class = shift; + my ($f, %params) = @_; + + my @out; + + push @out => ['control', 'HALT', $f->{control}->{details}] + if defined $f->{control}->{halt}; + + return @out unless $params{super_verbose}; + + push @out => ['control', 'ENCODING', $f->{control}->{encoding}] + if $f->{control}->{encoding}; + + return @out if @out; + + return ['control', 'CONTROL', $f->{control}->{details}] + if defined $f->{control}->{details}; + + return; +} + +my %SHOW_BRIEF_TAGS = ( + 'CRITICAL' => 1, + 'DEBUG' => 1, + 'DIAG' => 1, + 'ERROR' => 1, + 'FAIL' => 1, + 'FAILED' => 1, + 'FATAL' => 1, + 'HALT' => 1, + 'PASSED' => 1, + 'REASON' => 1, + 'STDERR' => 1, + 'TIMEOUT' => 1, + 'WARN' => 1, + 'WARNING' => 1, + 'KILL' => 1, + 'SKIPPED' => 1, +); + +my %SHOW_BRIEF_FACETS = ( + control => 1, + error => 1, + trace => 1, +); + +sub render_brief { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + if ($f->{render} && @{$f->{render}}) { + my @show = grep { $SHOW_BRIEF_TAGS{uc($_->{tag})} || $SHOW_BRIEF_FACETS{lc($_->{facet})} } @{$f->{render}}; + return [map { [$_->{facet}, uc($_->{tag}), $_->{details}] } @show]; + } + + my @out; + + push @out => $class->render_control($f) if $f->{control}; + + if ($f->{assert} && !$f->{assert}->{pass} && !$f->{amnesty}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{no_debug}; + } + + if ($f->{info}) { + my $if = {%$f, info => [grep { $_->{debug} || $_->{important} } @{$f->{info}}]}; + push @out => $class->render_info($if) if @{$if->{info}}; + } + + push @out => $class->render_errors($f) if $f->{errors}; + + return \@out; +} + +sub render_plan { + my $class = shift; + my ($f) = @_; + + my $plan = $f->{plan}; + return ['plan', 'NO PLAN', $f->{plan}->{details}] if $plan->{none}; + + if ($plan->{skip}) { + return ['plan', 'SKIP ALL', $f->{plan}->{details}] + if $f->{plan}->{details}; + + return ['plan', 'SKIP ALL', "No reason given"]; + } + + return ['plan', 'PLAN', "Expected assertions: $f->{plan}->{count}"]; +} + +sub render_assert { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details} || '<UNNAMED ASSERTION>'; + + return ['assert', '! PASS !', $name] + if $f->{amnesty} && @{$f->{amnesty}}; + + return ['assert', 'PASS', $name] + if $f->{assert}->{pass}; + + return ['assert', 'FAIL', $name] +} + +sub render_amnesty { + my $class = shift; + my ($f) = @_; + + my %seen; + return map { + $seen{join '' => @{$_}{qw/tag details/}}++ + ? () + : ['amnesty', $_->{tag}, $_->{details}] + } @{$f->{amnesty}}; +} + +sub render_debug { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug; + if ($trace) { + $debug = $trace->{details}; + if(!$debug && $trace->{frame}) { + my $frame = $trace->{frame}; + $debug = "$frame->[1] line $frame->[2]"; + } + } + + $debug ||= "[No trace info available]"; + + chomp($debug); + + return ['trace', 'DEBUG', $debug]; +} + +sub render_info { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details} // ''; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + ['info', $_->{tag}, $details, $_->{table} || ()] + } @{$f->{info}}; +} + +sub render_about { + my $class = shift; + my ($f) = @_; + + return if $f->{about}->{no_display}; + return unless $f->{about} && $f->{about}->{details}; + + my $type; + if ($f->{about}->{package}) { + my $type = $f->{about}->{package}; + $type =~ s/^.*:://; + } + $type //= 'ABOUT'; + + return ['about', $type, $f->{about}->{details}]; +} + +sub render_errors { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + my $tag = $_->{tag} || ($_->{fail} ? 'FATAL' : 'ERROR'); + + ['error', $tag, $details] + } @{$f->{errors}}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2::Composer - Compose output components from event facets + +=head1 DESCRIPTION + +This is used by L<Test2::Formatter::Test2> to turn events into output +components. This logic lives here instead of in the formatter because it is +also used by L<Test2::Harness::UI>. Other tools may also find this conversion +useful. + +=head1 SYNOPSIS + + use Test2::Formatter::Test2::Composer; + + # Note, all methods are class methods, this is just here for convenience. + my $comp = Test2::Formatter::Test2::Composer->new(); + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + ... + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=head1 METHODS + +All methods are class methods, but they also work just fine on a blessed +instance. There is no benefit to a blessed instance, but you can create one for +convenience if it makes you more comfortable. + +=over 4 + +=item $inst = $class->new() + +Create a blessed instance. This is here for convenience only. All methods are +class methods. + +=item $arrayref = $class->render_one_line($event) + +=item $arrayref = $class->render_one_line(\%facet_data) + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + +This will return a single line of output from the event, even if the event +would normally return multiple lines. + +In order of priority: + +=over 4 + +=item Custom 'render' facet + +=item Control 'halt' facet (bail-out) + +=item Assertion (pass/fail) + +=item Error message + +=item Plan + +=item Info (note/diag) + +=item Timing data + +=item About + +=back + +=item @lines = $class->render_verbose($event, %control_params) + +=item @lines = $class->render_verbose(\%facet_data, %control_params) + +This will verbosely render any event. The C<%control_params> are passed +directly to C<render_control()> and are not used for anything else. + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=item @lines = $class->render_super_verbose($event) + +=item @lines = $class->render_super_verbose(\%facet_data) + +This is even more verbose than C<render_verbose()> because it produces output +lines even for facets that should normally not be seen, things that would +usually be considered noise. + +This is mainly useful for tools that allow deep inspection of log files. + +=back + +=head2 FACET RENDERERS + +With exception of C<render_control()> these are all the same. These all take +C<\%facet_data> as their only argument, and return a list of line-arrayrefs +C<[$facet, $tag, $text_for_humans]>. + +=over 4 + +=item @lines = $class->render_control(\%facet_data, super_verbose => $bool) + +This specific one is special in that it can take an extra argument. This +argument is used to toggle between super_verbose and regular verbosity. No +other facet renderer needs this toggle. If omitted it defaults to not being +super verbose. + +=item @lines = $class->render_launch(\%facet_data) + +=item @lines = $class->render_start(\%facet_data) + +=item @lines = $class->render_exit(\%facet_data) + +=item @lines = $class->render_end(\%facet_data) + +=item @lines = $class->render_brief(\%facet_data) + +=item @lines = $class->render_plan(\%facet_data) + +=item @lines = $class->render_assert(\%facet_data) + +=item @lines = $class->render_amnesty(\%facet_data) + +=item @lines = $class->render_debug(\%facet_data) + +=item @lines = $class->render_info(\%facet_data) + +=item @lines = $class->render_about(\%facet_data) + +=item @lines = $class->render_errors(\%facet_data) + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness.pm b/libx/Test2/Harness.pm new file mode 100644 index 000000000..de5d06345 --- /dev/null +++ b/libx/Test2/Harness.pm @@ -0,0 +1,60 @@ +package Test2::Harness; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness - A new and improved test harness with better L<Test2> +integration. + +=head1 DESCRIPTION + +Test2::Harness is the backend code that handles running/processing the tests. +In general a user will not use it directly, instead you should probably be +looking at L<App::Yath> which is the UI layer built around Test2::Harness. + +=head1 SEE ALSO + +The primary documentation can be found in L<App::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/IPC/Model.pm b/libx/Test2/Harness/IPC/Model.pm new file mode 100644 index 000000000..c42d6a2d5 --- /dev/null +++ b/libx/Test2/Harness/IPC/Model.pm @@ -0,0 +1,48 @@ +package Test2::Harness::IPC::Model; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util::HashBase qw{ + <state <pid <run_id +}; + +sub init { + my $self = shift; + + $self->{+PID} //= $$; + croak "'state' is required" unless $self->{+STATE}; + croak "'run_id' is required" unless $self->{+RUN_ID}; +} + +sub establish_interactive_stdin { + my $self = shift; + + my $fh; + + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + open($fh, '<', $fifo) or die "Could not open fifo '$fifo': $!"; + } + elsif (-t STDIN) { + $fh = \*STDIN; + } + else { + confess "No human input source is available"; + } + + return $fh; +} + +sub get_test_stdout_pair { croak(blessed($_[0]) . '->get_test_stdout_pair() is not implemented') } +sub get_test_stderr_pair { croak(blessed($_[0]) . '->get_test_stderr_pair() is not implemented') } +sub get_test_events_pair { croak(blessed($_[0]) . '->get_test_events_pair() is not implemented') } +sub add_renderer { croak(blessed($_[0]) . '->add_renderer() is not implemented') } +sub render_event { croak(blessed($_[0]) . '->render_event() is not implemented') } + +sub finish {} + +1; diff --git a/libx/Test2/Harness/IPC/Model/AtomicPipe.pm b/libx/Test2/Harness/IPC/Model/AtomicPipe.pm new file mode 100644 index 000000000..dc6ca4911 --- /dev/null +++ b/libx/Test2/Harness/IPC/Model/AtomicPipe.pm @@ -0,0 +1,198 @@ +package Test2::Harness::IPC::Model::AtomicPipe; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use POSIX qw/mkfifo/; +use File::Path qw/make_path/; + +use File::Spec; +use Atomic::Pipe; + +use Test2::Util qw/get_tid/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +pair_cache + +renderer_writers +}; + +sub _get_mixed_pair { + my $self = shift; + + my ($r, $w) = Atomic::Pipe->pair(mixed_data_mode => 1); + + $r->resize($r->max_size); + $w->resize($w->max_size); + $w->wh->autoflush(1); + + my %out; + + my (@lines, @data); + my $read = sub { + if ($w) { + $w->close(); + $w = undef; + delete $out{write_ap}; + } + + while (1) { + my ($type, $val) = $r->get_line_burst_or_data; + last unless $type; + + if ($type eq 'message') { + push @data => decode_json($val); + } + elsif ($type eq 'line') { + push @lines => $val; + } + else { + die "Invalid type '$type'"; + } + } + }; + + my $read_line = sub { $read->(); my @out = @lines; @lines = (); return @out }; + my $read_data = sub { $read->(); my @out = @data; @data = (); return @out }; + + %out = ( + read_line => $read_line, + read_data => $read_data, + read_ap => $r, + write_ap => $w, + ); + + return \%out; +} + +sub get_test_stdout_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + return ($bits->{read_line}, $bits->{write_ap}->wh()); +} + +sub get_test_stderr_pair { + my $self = shift; + my ($r, $w) = Atomic::Pipe->pair; + $r->resize($r->max_size); + my $rh = $r->rh; + $rh->blocking(0); + $w->resize($w->max_size); + $w->wh->autoflush(1); + return (sub { <$rh> }, $w->wh()); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + my $writer_sub = sub { + if ($bits->{read_ap}) { + $bits->{read_ap}->close(); + delete $bits->{read_ap}; + delete $bits->{read_line}; + delete $bits->{read_data}; + } + + $bits->{write_ap}->write_message(encode_json($_)) for @_; + }; + + return ($bits->{read_data}, $writer_sub); +} + +sub add_renderer { + my $self = shift; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, 'renderers'); + make_path($path) unless -d $path; + + # Create file for fifo + my $id = gen_uuid(); + my $file = File::Spec->catfile($path, "${id}.fifo"); + + # make fifo + mkfifo($file, 0700) or die "Failed to create fifo"; + + my $r = Atomic::Pipe->read_fifo($file); + $r->resize($r->max_size); + $r->blocking(0); + + # add the fifo to state for future writers + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + my $files = $data->{render_files}->{$self->{+RUN_ID}} //= []; + push @$files => $file; + }); + + # return a sub to read the fifo + return sub { + my @out; + while (my $msg = $r->read_message) { + push @out => decode_json($msg); + } + return @out; + }; +} + +sub renderer_writers { + my $self = shift; + + if (my $have = $self->{+RENDERER_WRITERS}) { + return @{$have->{list} //= []} if $have->{pid} == $$ && $have->{tid} == get_tid(); + delete $self->{+RENDERER_WRITERS}; + delete $_->{out_buffer} for @{$have->{list} // []}; + } + + my @list; + for my $ap (@{$self->{+STATE}->data->{render_files}->{$self->{+RUN_ID}} // []}) { + my $w = Atomic::Pipe->write_fifo($ap); + $w->resize($w->max_size); + push @list => $w; + } + + $self->{+RENDERER_WRITERS} = { + pid => $$, + tid => get_tid(), + list => \@list, + }; + + return @list; +} + +sub render_event { + my $self = shift; + my ($e) = @_; + + my $json = encode_json($e); + + $_->write_message($json) for $self->renderer_writers; +} + +sub finish { + my $self = shift; + # Blocking flush on all/any renderer handles + + # First flush any that can be flushed without a wait + $_->flush(blocking => 0) for $self->renderer_writers; + + # Terminate the output + $self->render_event(undef); + + # Now we wait and flush all. + for my $ap ($self->renderer_writers) { + $ap->flush(blocking => 1); + $ap->close(); + } +} + +1; diff --git a/libx/Test2/Harness/IPC/Model/Files.pm b/libx/Test2/Harness/IPC/Model/Files.pm new file mode 100644 index 000000000..56c9eb2fe --- /dev/null +++ b/libx/Test2/Harness/IPC/Model/Files.pm @@ -0,0 +1,149 @@ +package Test2::Harness::IPC::Model::Files; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use File::Spec; +use File::Path qw/make_path/; + +use Test2::Util qw/get_tid ipc_separator/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Stream; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +render_writer +}; + +sub get_test_stdout_pair { + my $self = shift; + return $self->_get_std_pair(STDOUT => @_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->_get_std_pair(STDERR => @_); +} + +sub _get_std_pair { + my $self = shift; + my ($fname, $job_id, $job_try) = @_; + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, $job_id, $job_try); + + make_path($path) unless -d $path; + + my $file = File::Spec->catfile($path, $fname); + + open(my $wh, '>>', $file) or die "Could not open '$file' for writing: $!"; + + my $rs; + my $read_sub = sub { + $rs //= Test2::Harness::Util::File::Stream->new(name => $file); + $rs->poll(); + }; + + return ($read_sub, $wh); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $reader_sub = $self->_generate_reader(event_files => $job_id, $job_try); + my $writer_sub = $self->_generate_writer(event_files => $job_id, $job_try); + + return ($reader_sub, $writer_sub); +} + +sub add_renderer { + my $self = shift; + return $self->_generate_reader('render_files'); +} + +sub render_event { + my $self = shift; + my ($e) = @_; + my $writer = $self->{+RENDER_WRITER} //= $self->_generate_writer('render_files'); + $writer->($e); +} + +sub _generate_writer { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, $stream, $file) = (0, 0); + my $writer_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + $file = File::Spec->catfile($path, join(ipc_separator(), time, $pid, $tid) . ".jsonl"); + $stream = Test2::Harness::Util::File::JSONL->new(name => $file); + $self->{+STATE}->transaction(w => sub { + my ($state) = @_; + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + push @$files => $file; + }); + } + + $stream->write($_) for @_; + }; +} + +sub _generate_reader { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, %streams) = (0, 0); + my $reader_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + + # Clear stream cache on new proc/thread + %streams = (); + } + + my @events; + + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + for my $file (@$files) { + my $stream = $streams{$file} //= Test2::Harness::Util::File::JSONL->new(name => $file); + push @events => $stream->poll(); + } + + return @events; + }; + + return $reader_sub; +} + +sub _get_file_list { + my $self = shift; + my @path = @_; + my $last = pop @path; + + my $data = $self->{+STATE}->data; + $data = $data->{$_} //= {} for @path; + $data = $data->{$last} //= []; + return $data; +} + +sub finish { + my $self = shift; + $self->render_event(undef); +} + +1; diff --git a/libx/Test2/Harness/IPC/SharedState.pm b/libx/Test2/Harness/IPC/SharedState.pm new file mode 100644 index 000000000..769e302a2 --- /dev/null +++ b/libx/Test2/Harness/IPC/SharedState.pm @@ -0,0 +1,330 @@ +package Test2::Harness::IPC::SharedState; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Test2::Harness::Util::File::JSON; +use Scalar::Util qw/weaken blessed/; +use Time::HiRes qw/time stat/; +use Carp qw/croak confess/; +use Fcntl qw/:flock/; +use Errno qw/EINTR EAGAIN ESRCH/; + +use Test2::Harness::Util::HashBase qw{ + <state_file <state_fh <state_umask + + <access_id <access_pid <access_meta + <timeout + + +transaction + + <registered <unregistered +}; + +use constant LOCAL => 'local'; +use constant ACCESS => 'access'; + +sub state_class {} + +sub init { + my $self = shift; + + croak "'state_file' is a required attribute" unless $self->{+STATE_FILE}; + + $self->{+TIMEOUT} //= 300; # Timeout runs if they do not update at least every 5 min + $self->{+STATE_UMASK} //= 0007; +} + +sub state { shift->transaction('r') } +sub data { shift->transaction('r') } + +sub init_state { + my $self = shift; + return {timeout => $self->{+TIMEOUT}}; +} + +sub transaction { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $mode //= 'r'; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + croak "mode must be 'w', 'rw', 'r', or 'ro', got '$mode'" unless $write || $read; + + if ($write) { + confess "Write mode requires a 'access_id'" unless $self->access_id; + my $pid = $self->access_pid or confess "Write mode requires a 'access_pid'"; + confess "Access PID mismatch ($pid vs $$)" unless $$ == $pid; + } + + my ($lock, $state, $local, $new); + if ($state = $self->{+TRANSACTION}) { + $new = 0; + $local = $state->{+LOCAL}; + + confess "Attempted a 'write' transaction inside of a read-only transaction" + if $write && !$local->{write}; + } + else { + $new = 1; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $lockf = "$self->{+STATE_FILE}.LOCK"; + + open($lock, '>>', $lockf) or die "Could not open lock file '$lockf': $!"; + while (1) { + last if flock($lock, $write ? LOCK_EX : LOCK_SH); + next if $! == EINTR || $! == EAGAIN; + warn "Could not get lock: $!"; + } + + $state = $self->_read_state(); + 1; + }; + my $err = $@; + umask($oldmask); + die $err unless $ok; + + $local = $state->{+LOCAL} = { + lock => $lock, + mode => $mode, + write => $write, + stack => [{cb => $cb, args => \@args}], + }; + + weaken($state->{+LOCAL}->{lock}); + } + + local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => \@args}]) + if $self->{+TRANSACTION}; + + local $self->{+TRANSACTION} = $state; + + if ($new) { + if ($write) { + if ($self->registered) { + $self->_verify_registration($state); + } + else { + $self->_update_registration($state); + } + } + $self->_clear_old_registrations($state); + } + + my $out; + my $ok = eval { $out = $cb ? $self->$cb($state, @args) : $state; 1 }; + my $err = $@; + + if ($ok && $write && $new) { + $self->_clear_old_registrations($state); + $self->_update_registration($state) unless $self->{+UNREGISTERED}; + $self->_write_state($state); + } + + if ($lock) { + flock($lock, LOCK_UN) or die "Could not release lock: $!"; + } + + die $err unless $ok; + + return $out; +} + +sub _read_state { + my $self = shift; + + return $self->init_state unless -e $self->{+STATE_FILE}; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + + my ($ok, $err, $state); + for (1 .. 5) { + $ok = eval { $state = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.2; + } + + warn "Corrupted state? Resetting state to initial. Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + $state ||= $self->init_state; + + $self->sync_from_state($state); + + my $class = $self->state_class or return $state; + return $state if blessed($state); + return bless($state, $class); +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->{+TIMEOUT} = $state->{timeout}; +} + +sub _write_state { + my $self = shift; + my ($state) = @_; + + my $state_copy = {%$state}; + + my $local = delete $state_copy->{+LOCAL}; + + confess "Attempted write with no lock" unless $local->{lock}; + confess "Attempted write with a read-only lock" unless $local->{write}; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + $file->rewrite($state_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +sub update_registration { $_[0]->transaction(rw => '_update_registration') } +sub remove_registration { $_[0]->transaction(rw => '_update_registration', remove => 1) } + +sub _update_registration { + my $self = shift; + my ($state, %params) = @_; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id} //= { + %{$self->{+ACCESS_META} // {}}, + access_id => $access_id, + access_pid => $self->access_pid, + user => $ENV{USER}, + added => time, + }; + + # Update our last checkin time + $entry->{seen} = time; + + $self->{+REGISTERED} = $$; + + return $state unless $params{remove}; + + $self->{+UNREGISTERED} = 1; + $entry->{remove} = 1; + + return $state; +} + +sub _verify_registration { + my $self = shift; + my ($state) = @_; + + return unless $self->registered; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id}; + + # Do not allow for a new expiration. If the state has already expired us we will see it. + $entry->{seen} = time if $entry; + + return unless $self->{+UNREGISTERED} //= $self->_entry_expired($entry); + + confess "Shared state registration expired"; +} + +sub _entry_expired { + my $self = shift; + my ($entry) = @_; + + return 1 unless $entry; + return 1 if $entry->{remove}; + + if (my $pid = $entry->{+ACCESS_PID}) { + my $ret = kill(0, $pid); + my $err = $!; + return 1 if $ret == 0 && $! == ESRCH; + } + + my $seen = $entry->{seen} or return 1; + my $delta = time - $seen; + + return 1 if $self->{+TIMEOUT} && $delta > $self->{+TIMEOUT}; + + return 0; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $access = $state->{+ACCESS} //= {}; + + my (%removed); + for my $entry (values %$access) { + $entry->{remove} = 1 if $self->_entry_expired($entry); + next unless $entry->{remove}; + + my $access_id = $entry->{access_id}; + + $self->{+UNREGISTERED} = 1 if $access_id eq $self->access_id; + + delete $access->{$access_id}; + + $removed{$access_id}++; + } + + return [keys %removed]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::SharedState - IPC Shared State + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/State.pm b/libx/Test2/Harness/State.pm new file mode 100644 index 000000000..db1de5bc7 --- /dev/null +++ b/libx/Test2/Harness/State.pm @@ -0,0 +1,324 @@ +package Test2::Harness::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; + +use Test2::Harness::State::Instance; +use Test2::Harness::Settings; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util qw/mod2file clean_path/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <workdir + + +resources +resource_list + +plugins +plugin_list +plugin_lookup + +renderer +renderer_list +renderer_lookup + +job_count + +settings + + <observe + }, +); + +sub state_class { 'Test2::Harness::State::Instance' } + +sub clone { + my $self = shift; + my $copy = {%$self}; + delete $copy->{access_id}; + delete $copy->{access_pid}; + %$copy = (%$copy, @_) if @_; + return bless($copy, blessed($self)); +} + +sub access_id { $_[0]->_access->[0] } +sub access_pid { $_[0]->_access->[1] } +sub registered { $_[0]->_access->[2] } + +sub _access { + my $self = shift; + + my $id = $self->{+ACCESS_ID}; + my $pid = $self->{+ACCESS_PID}; + + if (defined $pid) { + return [$id // $pid, $pid, $self->{+REGISTERED} ? 1 : 0] if $pid && $pid == $$; + } + + if(defined($id) || defined($pid)) { + delete $self->{+ACCESS_ID}; + delete $self->{+ACCESS_PID}; + } + + if (my $rpid = $self->{+REGISTERED}) { + delete $self->{+REGISTERED} unless $rpid == $$; + } + + return [$$, $$, $self->{+REGISTERED} ? 1 : 0]; +} + +sub init { + my $self = shift; + + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + $self->SUPER::init(); + + my @bad = grep { !$self->can(uc($_)) } keys %$self; + croak "The following invalid keys were passed into the constructor: " . join(', ' => @bad) + if @bad; + + $self->{+PLUGIN_LOOKUP} //= {}; +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->SUPER::sync_from_state($state); + + $self->{+WORKDIR} = $state->{workdir}; +} + +sub init_state { + my $self = shift; + + confess "Attempt to initialize state from an observer" + if $self->{+OBSERVE}; + + my $state = $self->SUPER::init_state(); + + $state->{workdir} //= $self->{+WORKDIR}; + + my $settings = $state->{settings} //= $self->{+SETTINGS} //= Test2::Harness::Settings->new(File::Spec->catfile($self->{+WORKDIR}, 'settings.json')); + $state->{job_count} //= $self->{+JOB_COUNT} //= $settings->check_prefix('runner') ? $settings->runner->job_count // 1 : 1; + + for my $type (qw/resource plugin renderer/) { + my $plural = "${type}s"; + my $raw; + + if ($type eq 'resource') { + next unless $settings->check_prefix('runner'); + $raw = $settings->runner->$plural // []; + @$raw = sort { $a->sort_weight <=> $b->sort_weight } @$raw; + } + else { + next unless $settings->check_prefix('harness'); + $raw = $settings->harness->$plural // []; + } + + my $init_meth = "_init_${plural}"; + my ($list, $inst) = $self->$init_meth($settings, $raw); + + $state->{$plural} = $list; + $self->{"${type}_list"} = $list; + $self->{$plural} = $inst; + } + + return $state; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[0]->settings}) }); +} + +sub job_count { + my $self = shift; + return $self->{+JOB_COUNT} //= $self->transaction(r => sub { $_[0]->job_count }); +} + +sub _init_resources { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + my $has_limiter = undef; + + for my $res (@$list) { + require(mod2file($res)); + my $inst = $res->new(settings => $settings, observe => $self->{+OBSERVE}); + + push @inst => $inst; + push @store => $res; + + $has_limiter ||= $inst->job_limiter; + } + + unless ($has_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + push @store => 'Test2::Harness::Runner::Resource::JobCount'; + push @inst => Test2::Harness::Runner::Resource::JobCount->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + return (\@store, \@inst); +} + +sub resource_list { + my $self = shift; + return $self->{+RESOURCE_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $list; + }); +} + +sub resources { + my $self = shift; + return $self->{+RESOURCES} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $inst; + }); +} + +sub _init_plugins { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + for my $p (@$list) { + require(mod2file($p)); + push @store => $p; + + next unless $p->can('new'); + + my $inst = $p->new(settings => $settings); + push @inst => $inst; + } + + return (\@store, \@inst); +} + +sub plugin_list { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGIN_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $list; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "MODS-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +sub plugins { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGINS} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $inst; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "INST-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State - State tracking for a yath instance + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/State/Instance.pm b/libx/Test2/Harness/State/Instance.pm new file mode 100644 index 000000000..9c7ae59d4 --- /dev/null +++ b/libx/Test2/Harness/State/Instance.pm @@ -0,0 +1,67 @@ +package Test2::Harness::State::Instance; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <resources + <job_count + <settings + <workdir + <plugins + <runs + }, +); + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State::Instance - Data structure for yath shared state + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util.pm b/libx/Test2/Harness/Util.pm new file mode 100644 index 000000000..8ab7bbf51 --- /dev/null +++ b/libx/Test2/Harness/Util.pm @@ -0,0 +1,635 @@ +package Test2::Harness::Util; +use strict; +use warnings; + +use Carp qw/confess/; +use Cwd qw/realpath/; +use List::Util qw/min/; +use Test2::Util qw/try_sig_mask do_rename/; +use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; +use File::Spec; + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + find_libraries + clean_path + + parse_exit + mod2file + file2mod + fqmod + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + lock_file + unlock_file + + hub_truth + + apply_encoding + + process_includes + + chmod_tmp + + looks_like_uuid + is_same_file + + resize_pipe +}; + +sub resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh, $size) = @_; + + # 1mb if we can + $size //= 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub is_same_file { + my ($file1, $file2) = @_; + + return 0 unless defined $file1; + return 0 unless defined $file2; + + return 1 if "$file1" eq "$file2"; + return 1 if clean_path($file1) eq clean_path($file2); + + return 0 unless -e $file1; + return 0 unless -e $file2; + + my ($dev1, $inode1) = stat($file1); + my ($dev2, $inode2) = stat($file2); + + return 0 unless $dev1 == $dev2; + return 0 unless $inode1 == $inode2; + return 1; +} + +sub looks_like_uuid { + my ($in) = @_; + + return undef unless defined $in; + return undef unless length($in) == 36; + return undef unless $in =~ m/^[0-9A-F\-]+$/i; + return $in; +} + +sub chmod_tmp { + my $file = shift; + + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; + + chmod($mode, $file); +} + +sub process_includes { + my %params = @_; + + my @start = @{delete $params{list} // []}; + + my @list; + my %seen = ('.' => 1); + + if (my $ch_dir = delete $params{ch_dir}) { + for my $path (@start) { + # '.' is special. + $seen{'.'}++ and next if $path eq '.'; + + if (File::Spec->file_name_is_absolute($path)) { + push @list => $path; + } + else { + push @list => File::Spec->catdir($ch_dir, $path); + } + } + } + else { + @list = @start; + } + + push @list => @INC if delete $params{include_current}; + + @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + + @list = grep { !$seen{$_}++ } @list; + + # If we ask for dot, or saw it during our processing, add it to the end. + push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; + + confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + + return @list; +} + +sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); +} + +sub parse_exit { + my ($exit) = @_; + + my $sig = $exit & 127; + my $dmp = $exit & 128; + + return { + sig => $sig, + err => ($exit >> 8), + dmp => $dmp, + all => $exit, + }; +} + +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return "$prefix\::$input"; +} + +sub hub_truth { + my ($f) = @_; + + return $f->{hubs}->[0] if $f->{hubs} && @{$f->{hubs}}; + return $f->{trace} if $f->{trace}; + return {}; +} + +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} + +sub read_file { + my ($file, @args) = @_; + + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); + + return $out; +} + +sub write_file { + my ($file, @content) = @_; + + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); + + return @content; +}; + +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; + + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); + + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } + } + + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} + +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} + +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} + +sub write_file_atomic { + my ($file, @content) = @_; + + my $pend = "$file.pend"; + + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; + + die $err unless $ok; + + return @content; +} + +sub lock_file { + my ($file, $mode) = @_; + + my $fh; + if (ref $file) { + $fh = $file; + } + else { + open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; + } + + for (1 .. 21) { + flock($fh, LOCK_EX) and last; + die "Could not lock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not lock file: $!"; + } + + return $fh; +} + +sub unlock_file { + my ($fh) = @_; + for (1 .. 21) { + flock($fh, LOCK_UN) and last; + die "Could not unlock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not unlock file: $!"; + } + + return $fh; +} + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub mod2file { + my ($mod) = @_; + confess "No module name provided" unless $mod; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + return $file; +} + +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; +} + + +sub find_libraries { + my ($search, @paths) = @_; + my @parts = grep $_, split /::(\*)?/, $search; + + @paths = @INC unless @paths; + + @paths = map { File::Spec->canonpath($_) } @paths; + + my %prefixes = map {$_ => 1} @paths; + + my @found; + my @bases = ([map { [$_ => length($_)] } @paths]); + while (my $set = shift @bases) { + my $new_base = []; + my $part = shift @parts; + + for my $base (@$set) { + my ($dir, $prefix) = @$base; + if ($part ne '*') { + my $path = File::Spec->catdir($dir, $part); + if (@parts) { + push @$new_base => [$path, $prefix] if -d $path; + } + elsif (-f "$path.pm") { + push @found => ["$path.pm", $prefix]; + } + + next; + } + + opendir(my $dh, $dir) or next; + for my $item (readdir($dh)) { + next if $item =~ m/^\./; + my $path = File::Spec->catdir($dir, $item); + if (@parts) { + # Sometimes @INC dirs are nested in eachother. + next if $prefixes{$path}; + + push @$new_base => [$path, $prefix] if -d $path; + next; + } + + next unless -f $path && $path =~ m/\.pm$/; + push @found => [$path, $prefix]; + } + } + + push @bases => $new_base if @$new_base; + } + + my %out; + for my $found (@found) { + my ($path, $prefix) = @$found; + + my @file_parts = File::Spec->splitdir(substr($path, $prefix)); + shift @file_parts if $file_parts[0] eq ''; + + my $file = join '/' => @file_parts; + $file_parts[-1] = substr($file_parts[-1], 0, -3); + my $module = join '::' => @file_parts; + + $out{$module} //= $file; + } + + return \%out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util - General utiliy functions. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 MISC + +=over 4 + +=item apply_encoding($fh, $enc) + +Apply the specified encoding to the filehandle. + +B<Justification>: +L<PERLBUG 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923> +If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in +order to avoid the thread segfault. + +This is a reusable implementation of this: + + sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); + } + +=item $clean = clean_path($path) + +Take a file path and clean it up to a minimal absolute path if possible. Always +returns a path, but if it cannot be cleaned up it is unchanged. + +=item $hashref = find_libraries($search) + +=item $hashref = find_libraries($search, @paths) + +C<@INC> is used if no C<@paths> are provided. + +C<$search> should be a module name with C<*> wildcards replacing sections. + + find_libraries('Foo::*::Baz') + find_libraries('*::Bar::Baz') + find_libraries('Foo::Bar::*') + +These all look for modules matching the search, this is a good way to find +plugins, or similar patterns. + +The result is a hashref of C<< { $module => $path } >>. If a module exists in +more than 1 search path the first is used. + +=item $mod = fqmod($prefix, $mod) + +This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If +C<$mod> starts with the C<'+'> character the character will be removed and the +result returned without prepending C<$prefix>. + +=item hub_truth + +This is an internal implementation detail, do not use it. + +=item $hashref = parse_exit($?) + +This parses the exit value as typically stored in C<$?>. + +Resulting hash: + + { + sig => ($? & 127), # Signal value if the exit was caused by a signal + err => ($? >> 8), # Actual exit code, if any. + dmp => ($? & 128), # Was there a core dump? + all => $?, # Original exit value, unchanged + } + + +=item @list = process_includes(%PARAMS) + +This method will build up a list of include dirs fit for C<@INC>. The returned +list should contain only unique values, in proper order. + +Params: + +=over 4 + +=item list => \@START + +Paths to start the new list. + +Optional. + +=item ch_dir => $path + +Prefix to prepend to all paths in the C<list> param. No effect without an +initial list. + +=item include_current => $bool + +This will add all paths from C<@INC> to the output, after the initial list. +Note that '.', if in C<@INC> will be moved to the end of the final output. + +=item clean => $bool + +If included all paths except C<'.'> will be cleaned using C<clean_path()>. + +=item include_dot => $bool + +If true C<'.'> will be appended to the end of the output. + +B<Note> even if this is set to false C<'.'> may still be included if it was in +the initial list, or if it was in C<@INC> and C<@INC> was included using the +C<include_current> parameter. + +=back + +=back + +=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION + +These convert between module names like C<Foo::Bar> and filenames like +C<Foo/Bar.pm>. + +=over 4 + +=item $file = mod2file($mod) + +=item $mod = file2mod($file) + +=back + +=head2 FOR READING/WRITING FILES + +=over 4 + +=item $fh = open_file($path, $mode) + +=item $fh = open_file($path) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = read_file($file) + +This will open the file at C<$path> and return all its contents. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $fh = maybe_open_file($path) + +=item $fh = maybe_open_file($path, $mode) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +C<undef> is returned if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = maybe_read_file($path) + +This will open the file at C<$path> and return all its contents. + +This will return C<undef> if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item @content = write_file($path, @content) + +Write content to the specified file. This will open the file with mode +C<< '>' >>, write the content, then close the file. + +An exception will be thrown if any part fails. + +=item @content = write_file_atomic($path, @content) + +This will open a temporary file, write the content, close the file, then rename +the file to the desired C<$path>. This is essentially an atomic write in that +C<$file> will not exist until all content is written, preventing other +processes from doing a partial read while C<@content> is being written. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/File.pm b/libx/Test2/Harness/Util/File.pm new file mode 100644 index 000000000..6a19341f1 --- /dev/null +++ b/libx/Test2/Harness/Util/File.pm @@ -0,0 +1,256 @@ +package Test2::Harness::Util::File; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IO::Handle; + +use Test2::Harness::Util(); + +use Carp qw/croak confess/; +use Fcntl qw/SEEK_SET SEEK_CUR/; + +use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos <skip_bad_decode }; + +sub exists { -e $_[0]->{+NAME} } + +sub decode { shift; $_[0] } +sub encode { shift; $_[0] } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+_INIT_FH} = delete $self->{fh}; +} + +sub open_file { + my $self = shift; + return Test2::Harness::Util::open_file($self->{+NAME}, @_) +} + +sub maybe_read { + my $self = shift; + return undef unless -e $self->{+NAME}; + return $self->read; +} + +sub read { + my $self = shift; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +sub rewrite { + my $self = shift; + return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); +} + +sub write { + my $self = shift; + return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); +} + +sub reset { + my $self = shift; + delete $self->{+_FH}; + delete $self->{+DONE}; + delete $self->{+LINE_POS}; + return; +} + +sub fh { + my $self = shift; + return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; + + # Remove any other PID handles + $self->{+_FH} = {}; + + if (my $fh = $self->{+_INIT_FH}) { + $self->{+_FH}->{$$} = $fh; + } + else { + $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; + } + + $self->{+_FH}->{$$}->blocking(0); + return $self->{+_FH}->{$$}; +} + +sub read_line { + my $self = shift; + my %params = @_; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; + seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" + if eof($fh) || tell($fh) != $pos; + + my $line = <$fh>; + + # No line, nothing to do + return unless defined $line && length($line); + + # Partial line, hold off unless done + return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; + + my $new_pos = tell($fh); + die "Failed to 'tell': $!" if $new_pos == -1; + + my $err = 0; + local $@; + unless (eval { $line = $self->decode($line); 1 }) { + $err = $@ // 'error'; + confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; + warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; + $line = undef; + } + + $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; + return $line unless wantarray; + return ($pos, $new_pos, $line, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File - Utility class for manipulating a file. + +=head1 DESCRIPTION + +This is a utility class for file operations. This also serves as a base class +for several file helpers. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File; + + my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); + + $f->write($content); + + my $fh = $f->open_file('<'); + + # Read, throw exception if it cannot read + my $content = $f->read(); + + # Try to read, but do not throw an exception if it cannot be read. + my $content_or_undef = $f->maybe_read(); + + my $line1 = $f->read_line(); + my $line2 = $f->read_line(); + ... + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $f->name; + +Get the filename. Must also be provided during construction. + +=item $bool = $f->done; + +True if read_line() has read every line. + +=back + +=head1 METHODS + +=over 4 + +=item $decoded = $f->decode($encoded) + +This is a no-op, it returns the argument unchanged. This is called by C<read> +and C<read_line>. Subclasses can override this if the file contains encoded +data. + +=item $encoded = $f->encode($decoded) + +This is a no-op, it returns the argument unchanged. This is called by C<write>. +Subclasses can override this if the file contains encoded data. + +=item $bool = $f->exists() + +Check if the file exists + +=item $content = $f->maybe_read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will return undef. + +=item $fh = $f->open_file() + +=item $fh = $f->open_file($mode) + +Open a handle to the file. If no $mode is provided C<< '<' >> is used. + +=item $content = $f->read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will throw an exception. + +=item $line = $f->read_line() + +Read a single line from the file, subsequent calls will read the next line and +so on until the end of the file is reached. Reset with the C<reset()> method. + +=item $f->reset() + +Reset the internal line iterator used by C<read_line()>. + +=item $f->write($content) + +This is an atomic-write. First $content will be written to a temporary file +using C<< '>' >> mode. Then the temporary file will be renamed to the desired +file name. Under the hood this uses C<write_file_atomic()> from +L<Test2::Harness::Util>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/File/JSON.pm b/libx/Test2/Harness/Util/File/JSON.pm new file mode 100644 index 000000000..f3f6c5a1e --- /dev/null +++ b/libx/Test2/Harness/Util/File/JSON.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSON; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/pretty/; + +sub decode { shift; decode_json(@_) } +sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } + +sub reset { croak "line reading is disabled for json files" } +sub read_line { croak "line reading is disabled for json files" } + +sub maybe_read { + my $self = shift; + + return undef unless -e $self->{+NAME}; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + return undef unless defined($out) && length($out); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSON - Utility class for a JSON file. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> which automatically handles +encoding/decoding JSON data. + +=head1 SYNOPSIS + + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); + + $hash = $file->read; + # or + $$file->write({...}); + +=head1 SEE ALSO + +See the base class L<Test2::Harness::Util::File> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/File/JSONL.pm b/libx/Test2/Harness/Util/File/JSONL.pm new file mode 100644 index 000000000..ce64c51b3 --- /dev/null +++ b/libx/Test2/Harness/Util/File/JSONL.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSONL; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::Util::File::Stream'; +use Test2::Harness::Util::HashBase; + +sub decode { shift; decode_json($_[0]) } +sub encode { shift; encode_json(@_) . "\n" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> which automatically handles +encoding/decoding JSONL data. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + while (1) { + my @items = $jsonl->poll(max => 1000) or last; + for my $item (@items) { + ... handle $item ... + } + } + +or + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + $jsonl->write({my => 'item', ... }); + ... + +=head1 SEE ALSO + +See the base classes L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/File/Stream.pm b/libx/Test2/Harness/Util/File/Stream.pm new file mode 100644 index 000000000..d9dece480 --- /dev/null +++ b/libx/Test2/Harness/Util/File/Stream.pm @@ -0,0 +1,207 @@ +package Test2::Harness::Util::File::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/lock_file unlock_file/; +use Fcntl qw/SEEK_SET/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/use_write_lock -tail/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + my $tail = $self->{+TAIL} or return; + + return unless $self->exists; + + my @lines = $self->poll_with_index; + if (@lines < $self->{+TAIL}) { + $self->seek(0); + } + else { + $self->seek($lines[0 - $tail]->[0]); + } +} + +sub poll_with_index { + my $self = shift; + my %params = @_; + + my $max = delete $params{max} || 0; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my @out; + while (!$max || @out < $max) { + my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); + last unless defined($line) || defined($spos) || defined($epos) || $err; + + $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; + push @out => [$spos, $epos, $line] unless $err; + $pos = $epos; + } + + return @out; +} + +sub read { + my $self = shift; + + return $self->poll(from => 0); +} + +sub poll { + my $self = shift; + my @lines = $self->poll_with_index(@_); + return map { $_->[-1] } @lines; +} + +sub write { + my $self = shift; + + my $name = $self->{+NAME}; + + my $fh; + if ($self->{+USE_WRITE_LOCK}) { + $fh = lock_file($self->name, '>>'); + } + else { + $fh = Test2::Harness::Util::open_file($self->name, '>>'); + } + + $fh->autoflush(1); + seek($fh,2,0); + print {$fh} $self->encode($_) for @_; + + unlock_file($fh) if $self->{+USE_WRITE_LOCK}; + + close($fh) or die "Could not close file '$name': $!"; + + return @_; +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + my $fh = $self->fh; + my $name = $self->{+NAME}; + + seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; + $self->{+LINE_POS} = $pos; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Stream - Utility class for manipulating a file that +serves as an output stream. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::File> that streams the contents of a file, even +if the file is still being written. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Stream; + + my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); + + # Read some lines + my @lines = $stream->poll; + + ... + + # Read more lines, if any. + push @lines => $stream->poll; + +=head1 ATTRIBUTES + +See L<Test2::Harness::File> for additional attributes. + +These can be passed in as construction arguments if desired. + +=over 4 + +=item $bool = $stream->use_write_lock + +=item $stream->use_write_lock($bool) + +Lock the file for every C<write()> operation. + +=item $bool = $stream->tail + +Start near the end of the file and only poll for updates appended to it. + +=back + +=head1 METHODS + +See L<Test2::Harness::File> for additional methods. + +=over 4 + +=item @lines = $stream->read() + +Read all lines from the beginning. Every time it is called it returns ALL lines. + +=item @lines = $stream->poll() + +=item @lines = $stream->poll(max => $int) + +Poll for lines. This is an iterator, it should not return the same line more +than once, you can call it multiple times to get any additional lines that have +been added since the last poll. + +=item $stream->write(@content) + +Append @content to the file. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/File/Value.pm b/libx/Test2/Harness/Util/File/Value.pm new file mode 100644 index 000000000..bf291ba5b --- /dev/null +++ b/libx/Test2/Harness/Util/File/Value.pm @@ -0,0 +1,100 @@ +package Test2::Harness::Util::File::Value; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + $self->{+DONE} = 1; +} + +sub read { + my $self = shift; + my $out = $self->SUPER::read(@_); + chomp($out) if defined $out; + return $out; +} + +sub read_line { + my $self = shift; + my $out = $self->SUPER::read_line(@_); + chomp($out) if defined $out; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Value - Utility class for a file that contains +exactly 1 value. + +=head1 DESCRIPTION + +This is a subclass of L<Test2::Harness::Util::File> for files expected to have +exactly 1 value stored in them. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Value; + + my $vf = Test2::Harness::Util::File::Value->new(name => 'path/to/file'); + my $val = $vf->read; + +=head1 METHODS + +=over 4 + +=item $val = $vf->read() + +Read all contents from the file, C<chomp()> it, and return it. + +=item $val = $vf->read_line() + +Read the first line from the file, C<chomp()> it, and return it. Note, this +may not return anything if the value in the file does not terminate with a +newline. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/HashBase.pm b/libx/Test2/Harness/Util/HashBase.pm new file mode 100644 index 000000000..0146e1c7c --- /dev/null +++ b/libx/Test2/Harness/Util/HashBase.pm @@ -0,0 +1,473 @@ +package Test2::Harness::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.008'; + *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub import { + my $class = shift; + my $into = caller; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; + $Test2::Harness::Util::HashBase::VERSION{$into} = $ver if !$Test2::Harness::Util::HashBase::VERSION{$into} || $Test2::Harness::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Harness::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Harness::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Harness::Util::HashBase>. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Harness::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B<Note:> Test2::Harness::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Harness::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'s key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Harness::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Harness::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Harness::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Harness::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Harness::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Harness::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Harness::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Harness::Util::HashBase class. + +=over 4 + +=item @list = Test2::Harness::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Harness::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/IPC.pm b/libx/Test2/Harness/Util/IPC.pm new file mode 100644 index 000000000..88e45a35f --- /dev/null +++ b/libx/Test2/Harness/Util/IPC.pm @@ -0,0 +1,326 @@ +package Test2::Harness::Util::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Cwd qw/getcwd/; +use Config qw/%Config/; +use Test2::Util qw/CAN_REALLY_FORK/; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + USE_P_GROUPS + run_cmd + swap_io +}; + +BEGIN { + if ($Config{'d_setpgrp'}) { + *USE_P_GROUPS = sub() { 1 }; + } + else { + *USE_P_GROUPS = sub() { 0 }; + } +} + +if (CAN_REALLY_FORK) { + *run_cmd = \&_run_cmd_fork; +} +else { + *run_cmd = \&_run_cmd_spwn; +} + +sub swap_io { + my ($fh, $to, $die, $mode) = @_; + + $die ||= sub { + my @caller = caller; + my @caller2 = caller(1); + die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); + }; + + my $orig_fd; + if (ref($fh) eq 'ARRAY') { + ($orig_fd, $fh) = @$fh; + } + else { + $orig_fd = fileno($fh); + } + + $die->("Could not get original fd ($fh)") unless defined $orig_fd; + + if (ref($to)) { + $mode //= $orig_fd ? '>&' : '<&'; + open($fh, $mode, $to) or $die->("Could not redirect output: $!"); + } + else { + $mode //= $orig_fd ? '>' : '<'; + open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); + } + + return if fileno($fh) == $orig_fd; + + $die->("New handle does not have the desired fd!"); +} + +sub _run_cmd_fork { + my %params = @_; + + my $cmd = $params{command} or die "No 'command' specified"; + + my $pid = fork; + die "Failed to fork" unless defined $pid; + if ($pid) { + $_->() for @{$params{run_in_parent} // []}; + return $pid; + } + else { + $_->() for @{$params{run_in_child} // []}; + } + %ENV = (%ENV, %{$params{env}}) if $params{env}; + setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp}; + + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + if (my $dir = $params{chdir} // $params{ch_dir}) { + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDERR, $stderr, $die) if $stderr; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + swap_io(\*STDIN, $stdin, $die) if $stdin; + open(STDIN, "<", "/dev/null") if !$stdin; + + @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd; + + exec(@$cmd) or $die->("Failed to exec!"); +} + +sub _run_cmd_spwn { + my %params = @_; + + local %ENV = (%ENV, %{$params{env}}) if $params{env}; + + my $cmd = $params{command} or die "No 'command' specified"; + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + my $cwd; + if (my $dir = $params{chdir} // $params{ch_dir}) { + $cwd = getcwd(); + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDIN, '<&', \*STDIN) or die "Could not clone STDIN: $!"; + open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!"; + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $stdin, $die) if $stdin; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + $stdin ? swap_io(\*STDIN, $stdin, $die) : close(STDIN); + + local $?; + my $pid; + my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd }; + my $bad = $?; + my $err = $@; + + swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die); + swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr; + swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout; + + if ($cwd) { + chdir($cwd) or die "Could not chdir: $!"; + } + + die $err unless $ok; + die "Spawn resulted in code $bad" if $bad && $bad != $pid; + die "Failed to spawn" unless $pid; + + $_->() for @{$params{run_in_parent} // []}; + + return $pid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::IPC - Utilities for IPC management. + +=head1 DESCRIPTION + +This package provides low-level IPC tools for Test2::Harness. + +=head1 EXPORTS + +All exports are optional and must be specified at import time. + +=over 4 + +=item $bool = USE_P_GROUPS() + +This is a shortcut for: + + use Config qw/%Config/; + $Config{'d_setpgrp'}; + +=item swap_io($from, $to) + +=item swap_io($from, $to, \&die) + +This will close and re-open the file handle designated by C<$from> so that it +redirects to the handle specified in C<$to>. It preserves the file descriptor +in the process, and throws an exception if it fails to do so. + + swap_io(\*STDOUT, $fh); + # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'. + +As long as the file descriptor is greater than 0 it will open for writing. If +the descriptor is 0 it will open for reading, allowing for a swap of C<STDIN> +as well. + +Extra effort is made to insure errors go to the real C<STDERR>, specially when +trying to swap out C<STDERR>. If you have trouble with this, or do not trust +it, you can provide a custom coderef as a third argument, this coderef will be +used instead of C<die()> to throw exceptions. + +Note that the custom die logic when you do not provide your own bypasses the +exception catching mechanism and will exit your program. If this is not +desirable then you should provide a custom die subref. + +=item $pid = run_cmd(command => [...], %params) + +This function will run the specified command and return a pid to you. When +possible this will be done via C<fork()> and C<exec()>. When that is not +possible it uses the C<system(1, ...)> trick to spawn a new process. Some +parameters do not work in the second case, and are silently ignored. + +Parameters: + +=over 4 + +=item command => [$command, sub { ... }, @args] + +=item command => sub { return ($command, @args) } + +This parameter is required. This should either be an arrayref of arguments for +C<exec()>, or a coderef that returns a list of arguments for C<exec()>. On +systems without fork/exec the arguments will be passed to +C<system(1, $command, @args)> instead. + +If the command arrayref has a coderef in it, the coderef will be run and its +return value(s) will be inserted in its place. This replacement happens +post-chroot + +=item run_in_parent => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the parent process immedietly after the +child process is started. + +=item run_in_child => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the child process immedietly after fork. +This parameter is silently ignored on systems without fork/exec. + +=item env => { ENVVAR => $VAL, ... } + +A hashref of custom environment variables to set in the child process. In the +fork/exec model this is done post-fork, in the spawn model this is done via +local prior to the spawn. + +=item no_set_pgrp => $bool, + +Normall C<setpgrp(0,0)> is called on systems where it is supported. You can use +this parameter to override the normal behavior. setpgrp() is not called in the +spawn model, so this parameter is silently ignored there. + +=item chdir => 'path/to/dir' + +=item ch_dir => 'path/to/dir' + +chdir() to the specified directory for the new process. In the fork/exec model +this is done post-fork in the child. In the spawn model this is done before the +spawn, then a second chdir() puts the parent process back to its original dir +after the spawn. + +=item stdout => $handle + +=item stderr => $handle + +=item stdin => $handle + +Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec +model these are swapped into place post-fork in the child. In the spawn model +the swap occurs pre-spawn, then the old handles are swapped back post-spawn. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/JSON.pm b/libx/Test2/Harness/Util/JSON.pm new file mode 100644 index 000000000..2c73ec443 --- /dev/null +++ b/libx/Test2/Harness/Util/JSON.pm @@ -0,0 +1,263 @@ +package Test2::Harness::Util::JSON; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +BEGIN { + local $@ = undef; + my $ok = eval { + require JSON::MaybeXS; + JSON::MaybeXS->import('JSON'); + 1; + + if (JSON() eq 'JSON::PP') { + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + elsif (JSON() eq 'JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 1 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + elsif (JSON() eq 'Cpanel::JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 1 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + }; + + unless ($ok) { + require JSON::PP; + *JSON = sub() { 'JSON::PP' }; + + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + +} + +our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; +our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); +my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); + +sub encode_json { $json->encode(@_) } +sub encode_canon_json { $canon->encode(@_) } +sub encode_pretty_json { $pretty->encode(@_) } + +sub decode_json { + my ($input) = @_; + my $data; + + local $@; + my $error; + + # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally + # testing bytes behavior we need to accept the bytes from the JSON file instead. + my $ok = eval { $data = $json->decode($input); 1 } || do { + $error = $@; + eval { $data = $json_non_utf8->decode($input); 1 }; + }; + $error ||= $@; + return $data if $ok; + my $mess = Carp::longmess("JSON decode error: $error"); + die "$mess\n=======\n$input\n=======\n"; +} + +sub stream_json_l { + my ($path, $handler, %params) = @_; + + croak "No path provided" unless $path; + + return stream_json_l_file($path, $handler) if -f $path; + return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; + + croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; +} + +sub stream_json_l_file { + my ($path, $handler) = @_; + + croak "Invalid file '$path'" unless -f $path; + + croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." + unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; + + if ($1 eq 'json') { + require Test2::Harness::Util::File::JSON; + my $json = Test2::Harness::Util::File::JSON->new(name => $path); + $handler->($json->read); + } + else { + require Test2::Harness::Util::File::JSONL; + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); + while (my ($item) = $jsonl->poll(max => 1)) { + $handler->($item); + } + } + + return 1; +} + +sub stream_json_l_url { + my ($path, $handler, %params) = @_; + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args} // []; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + my $buffer = ''; + my $iterate = sub { + my ($res) = @_; + + my @parts = split /(\n)/, $buffer; + + while (@parts > 1) { + my $line = shift @parts; + my $nl = shift @parts; + my $data; + unless (eval { $data = decode_json($line); 1 }) { + warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; + next; + } + + $handler->($data, $res); + } + + $buffer = shift @parts // ''; + }; + + my $res = $ht->$meth( + $path, + { + @$args, + data_callback => sub { + my ($chunk, $res) = @_; + $buffer .= $chunk; + $iterate->($res); + }, + } + ); + + if (length($buffer)) { + $buffer .= "\n" unless $buffer =~ m/\n$/; + $iterate->($res); + } + + return $res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best +JSON implementation. + +=head1 DESCRIPTION + +This package provides functions for encoding/decoding json, and uses the best +json tools available. + +=head1 SYNOPSIS + + use Test2::Harness::Util::JSON qw/encode_json decode_json/; + + my $data = { foo => 1 }; + my $json = encode_json($data); + my $copy = decode_json($json); + +=head1 EXPORTS + +=over 4 + +=item $package = JSON() + +This returns the JSON package being used by yath. + +=item $bool = JSON_IS_PP() + +True if yath is using L<JSON::PP>. + +=item $bool = JSON_IS_XS() + +True if yath is using L<JSON::XS>. + +=item $bool = JSON_IS_CPANEL() + +True if yath is using L<Cpanel::JSON::XS>. + +=item $bool = JSON_IS_CPANEL_OR_XS() + +True if either L<JSON::XS> or L<Cpanel::JSON::XS> are being used. + +=item $string = encode_json($data) + +Encode data into json. String will be 1-line. + +=item $data = decode_json($string) + +Decode json data from the string. + +=item $string = encode_pretty_json($data) + +Encode into human-friendly json. + +=item $string = encode_canon_json($data) + +Encode into canon-json. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/Queue.pm b/libx/Test2/Harness/Util/Queue.pm new file mode 100644 index 000000000..efe7289b3 --- /dev/null +++ b/libx/Test2/Harness/Util/Queue.pm @@ -0,0 +1,213 @@ +package Test2::Harness::Util::Queue; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/write_file_atomic/; + +use Test2::Harness::Util::File::JSONL(); + +use Test2::Harness::Util::HashBase qw{ + -file -qh -ended +}; + +sub init { + my $self = shift; + + croak "'file' is a required attribute" + unless $self->{+FILE}; +} + +sub start { + my $self = shift; + write_file_atomic($self->{+FILE}, ""); +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + $self->{+QH}->seek($pos); + + return $pos; +} + +sub reset { + my $self = shift; + delete $self->{+QH}; +} + +sub poll { + my $self = shift; + my $max = shift; + + return $self->{+ENDED} if $self->{+ENDED}; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + my @out = $self->{+QH}->poll_with_index( $max ? (max => $max) : () ); + + $self->{+ENDED} = $out[-1] if @out && !defined($out[-1]->[-1]); + + return @out; +} + +sub end { + my $self = shift; + $self->_enqueue(undef); +} + +sub enqueue { + my $self = shift; + my ($task) = @_; + + croak "Invalid task" + unless $task && ref($task) eq 'HASH' && values %$task; + + $task->{stamp} ||= time; + + $self->_enqueue($task); +} + +sub _enqueue { + my $self = shift; + my ($task) = @_; + + my $fh = Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}, use_write_lock => 1); + $fh->write($task); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Queue - Representation of a queue. + +=head1 DESCRIPTION + +This module represents a queue, stored as a jsonl file. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + $queue->start(); # Create the queue + + $queue->enqueue({foo => 'bar', baz => 'bat'}); + $queue->enqueue({foo => 'bar2', baz => 'bat2'}); + ... + + $queue->end(); + +Then in another processs: + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + my @items; + while (1) { + @items = $queue->poll(); + while (@items) { + my $item = shift @items or last; + + ... process $item + } + + # Queue ends with an 'undef' entry + last if @items && !defined($items[0]); + } + +=head1 METHODS + +=over 4 + +=item $path = $queue->file + +The filename used for the queue + +=back + +=head2 READING + +=over 4 + +=item $queue->reset() + +Restart reading the queue. + +=item @items = $queue->poll() + +Get more items from the queue. May need to call it multiple times, specially if +another process is still writing to the queue. + +Returns an empty list if no items are available yet. + +Returns 'undef' to terminate the list. + +=item $bool = $queue->ended() + +Check if the queue has ended. + +=back + +=head1 WRITING + +=over 4 + +=item $queue->start() + +Open the queue file for writing. + +=item $queue->enqueue(\%HASHREF) + +Add an item to the queue. + +=item $queue->end() + +Terminate the queue. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/Term.pm b/libx/Test2/Harness/Util/Term.pm new file mode 100644 index 000000000..da0b6a306 --- /dev/null +++ b/libx/Test2/Harness/Util/Term.pm @@ -0,0 +1,104 @@ +package Test2::Harness::Util::Term; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; + +use Importer Importer => 'import'; +our @EXPORT_OK = qw/USE_ANSI_COLOR/; + +{ + my $use = 0; + local ($@, $!); + + if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { + if (IS_WIN32) { + if (eval { require Win32::Console::ANSI }) { + Win32::Console::ANSI->import(); + $use = 1; + } + } + else { + $use = 1; + } + } + + if ($use) { + *USE_ANSI_COLOR = sub() { 1 }; + } + else { + *USE_ANSI_COLOR = sub() { 0 }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Term - Terminal utilities for Test2::Harness + +=head1 DESCRIPTION + +This module provides information about the terminal in which the harness is +running. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + + if (USE_ANSI_COLOR) { + ... + } + else { + ... + } + +=head1 EXPORTS + +=over 4 + +=item $bool = USE_ANSI_COLOR() + +True if L<Term::ANSIColor> is available and usable. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Harness/Util/UUID.pm b/libx/Test2/Harness/Util/UUID.pm new file mode 100644 index 000000000..459bea92e --- /dev/null +++ b/libx/Test2/Harness/Util/UUID.pm @@ -0,0 +1,85 @@ +package Test2::Harness::Util::UUID; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Data::UUID; +use Importer 'Importer' => 'import'; + +our @EXPORT = qw/gen_uuid/; +our @EXPORT_OK = qw/UG gen_uuid/; + +my ($UG, $UG_PID); +sub UG { + return $UG if $UG && $UG_PID && $UG_PID == $$; + + $UG_PID = $$; + return $UG = Data::UUID->new; +} + +sub gen_uuid { UG()->create_str() } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::UUID - Utils for generating UUIDs. + +=head1 DESCRIPTION + +This module provides a consistent UUID source for all of Test2::Harness. + +=head1 SYNOPSIS + + use Test2::Harness::Util::UUID qw/gen_uuid/; + + my $uuid = gen_uuid; + +=head1 EXPORTS + +=over 4 + +=item $uuid = gen_uuid() + +Generate a UUID. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/libx/Test2/Tools/HarnessTester.pm b/libx/Test2/Tools/HarnessTester.pm new file mode 100644 index 000000000..e48090390 --- /dev/null +++ b/libx/Test2/Tools/HarnessTester.pm @@ -0,0 +1,179 @@ +package Test2::Tools::HarnessTester; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Tester qw/make_example_dir/; + +use Importer Importer => qw/import/; +our @EXPORT_OK = qw/make_example_dir summarize_events/; + +my $HARNESS_ID = 1; +sub summarize_events { + my ($events) = @_; + + my @caller = caller(0); + + my $id = $HARNESS_ID++; + my $run_id = "run-$id"; + my $job_id = "job-$id"; + + require Test2::Harness::Auditor::Watcher; + my $watcher = Test2::Harness::Auditor::Watcher->new(job => 1, try => 0); + + require Test2::Harness::Event; + for my $e (@$events) { + my $fd = $e->facet_data; + my $he = Test2::Harness::Event->new( + facet_data => $fd, + event_id => gen_uuid(), + run_id => $run_id, + job_id => $job_id, + stamp => time, + job_try => 0, + ); + + $watcher->process($he); + } + + return { + plan => $watcher->plan, + pass => $watcher->pass ? 1 : 0, + fail => $watcher->fail ? 1 : 0, + errors => $watcher->_errors, + failures => $watcher->_failures, + assertions => $watcher->assertion_count, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::HarnessTester - Run events through a harness for a summary + +=head1 DESCRIPTION + +This tool allows you to process events through the L<Test2::Harness> auditor. +The main benefit here is to get a pass/fail result, as well as counts for +assertions, failures, and errors. + +=head1 SYNOPSIS + + use Test2::V0; + use Test2::API qw/intercept/; + use Test2::Tools::HarnessTester qw/summarize_events/; + + my $events = intercept { + ok(1, "pass"); + ok(2, "pass gain"); + done_testing; + }; + + is( + summarize_events($events), + { + # Each of these is the negation of the other, no need to check both + pass => 1, + fail => 0, + + # The plan facet, see Test2::EventFacet::Plan + plan => {count => 2}, + + # Statistics + assertions => 2, + errors => 0, + failures => 0, + } + ); + +=head1 EXPORTS + +=head2 $summary = summarize_events($events) + +This takes an arrayref of events, such as that produced by C<intercept {...}> +from L<Test2::API>. The result is a hashref that summarizes the results of the +events as processed by L<Test2::Harness>, specifically the +L<Test2::Harness::Auditor::Watcher> module. + +Fields in the summary hash: + +=over 4 + +=item pass => $BOOL + +=item fail => $BOOL + +These are negatives of eachother. These represent the pass/fail state after +processing the events. When one is true the other should be false. These are +normalized to C<1> and C<0>. + +=item plan => $HASHREF + +If a plan was provided this will have the L<Test2::EventFacet::Plan> facet, but +as a hashref, not a blessed instance. + +B<Note:> This is reference to the original data, not a copy, if you modify it +you will modify the event as well. + +=item assertions => $INT + +Count of assertions made. + +=item errors => $INT + +Count of errors seen. + +=item failures => $INT + +Count of failures seen. + +=back + +=head2 $path = make_example_dir() + +This will create a temporary directory with 't', 't2', and 'xt' subdirectories +each of which will contain a single passing test. + +This is re-exported from L<App::Yath::Tester>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath.pm b/liby/App/Yath.pm new file mode 100644 index 000000000..2d38ff012 --- /dev/null +++ b/liby/App/Yath.pm @@ -0,0 +1,879 @@ +package App::Yath; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw{ + -config + -settings + + -_options -options_loaded + -_argv -argv_processed <_orig_argv + + -_command_class -_command_name -_early_command +}; + +use Time::HiRes qw/time/; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/find_libraries clean_path/; +use App::Yath::Options(); +use Scalar::Util qw/blessed/; + +my $APP_PATH = __FILE__; +$APP_PATH =~ s{App\S+Yath\.pm$}{}g; +$APP_PATH = clean_path($APP_PATH); +sub app_path { $APP_PATH } + +sub init { + my $self = shift; + + my $old = select STDOUT; + $| = 1; + select STDERR; + $| = 1; + select $old; + + my @caller = caller(1); + + $self->{+SETTINGS} //= Test2::Harness::Settings->new; + + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('script')} //= clean_path($caller[1]); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('start')} //= time(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('no_scan_plugins')} //= 0; + + $self->{+_ARGV} //= delete($self->{argv}) // []; + $self->{+_ORIG_ARGV} = [@{$self->{+_ARGV}}]; + $self->{+CONFIG} //= {}; +} + +sub generate_run_sub { + my $self = shift; + my ($symbol) = @_; + + my $cmd_class; + my ($options, $argv); + + if (my $cmd = $self->_command_from_argv(no_default => 1, valid_only => 1)) { + $cmd_class = $self->load_command($cmd); + + $self->{+_COMMAND_NAME} = $cmd; + $self->{+_COMMAND_CLASS} = $cmd_class; + + if ($cmd_class->only_cmd_opts) { + $self->{+_EARLY_COMMAND} = 1; + my $settings = $self->{+SETTINGS}; + + $options = App::Yath::Options->new(settings => $settings); + $options->set_command_class($cmd_class); + $options->set_args($self->{+_ARGV}); + + $argv = $self->{+_ARGV}; + $cmd_class->munge_opts($options, $argv, $settings); + } + } + + $options //= $self->load_options(); + + $cmd_class //= $self->command_class(); + ${$self->{+SETTINGS}->define_prefix('harness')->vivify_field('command')} //= $cmd_class; + + $argv = $self->process_argv(); + + return $cmd_class->generate_run_sub($symbol, $argv, $self->{+SETTINGS}, $self->{+_ORIG_ARGV}) if $cmd_class->can('generate_run_sub'); + + my $cmd = $cmd_class->new(settings => $options->settings, args => $argv, orig_args => $self->{+_ORIG_ARGV}); + + $options->process_option_post_actions($cmd); + + my $run = sub { $self->run_command($cmd) }; + + { + no strict 'refs'; + *{$symbol} = $run; + } + + return; +} + +sub run_command { + my $self = shift; + my ($cmd) = @_; + + my $exit = $cmd->run; + + die "Command '" . $cmd->name() . "' did not return an exit value.\n" + unless defined $exit; + + return $exit; +} + +sub load_options { + my $self = shift; + + my $settings = $self->{+SETTINGS} = $self->{+SETTINGS}; + + my $options = $self->{+_OPTIONS} //= App::Yath::Options->new(settings => $settings); + + return $options if $self->{+OPTIONS_LOADED}++; + + $options->include_from( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ); + + return $options if $self->{+SETTINGS}->harness->no_scan_plugins; + + my $option_libs = { + %{find_libraries('App::Yath::Plugin::*')}, + %{find_libraries('Test2::Harness::Runner::Resource::*')}, + }; + for my $lib (sort keys %$option_libs) { + my $ok = eval { require $option_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load module '$option_libs->{$lib}': $@"; + next; + } + + next unless $lib->can('options'); + my $add = $lib->options; + next unless $add; + + unless (blessed($add) && $add->isa('App::Yath::Options')) { + warn "Module '$option_libs->{$lib}' is outdated, not loading options.\n" + unless $ENV{'YATH_SELF_TEST'}; + next; + } + + $options->include_from($lib); + } + + return $options; +} + +sub process_argv { + my $self = shift; + + return $self->{+_ARGV} if $self->{+ARGV_PROCESSED}++; + + my $options = $self->load_options(); + my $settings = $self->settings; + + my $config_pre_args = $self->{+CONFIG}->{'~'}; + $options->grab_pre_command_opts(args => $config_pre_args, stop_at_non_opt => 0, passthrough => 0, die_at_non_opt => 1) + if $config_pre_args; + + $options->set_args($self->{+_ARGV}); + $options->grab_pre_command_opts(); + + $options->process_pre_command_opts(); + + my $cmd_name = $self->_command_from_argv(); + my $cmd_class = $self->load_command($cmd_name); + die "Command '$cmd_name' needs to be specified earlier in the command line arguments to yath.\n" if $cmd_class->only_cmd_opts && !$self->{+_EARLY_COMMAND}; + $options->set_command_class($cmd_class); + $self->{+_COMMAND_CLASS} = $cmd_class; + + $options->grab_pre_command_opts(stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0); + + my $config_cmd_args = $self->{+CONFIG}->{$cmd_name}; + + $options->grab_pre_command_opts(args => $config_cmd_args, stop_at_non_opt => 1, passthrough => 1, die_at_non_opt => 0) + if $config_cmd_args; + + $options->process_pre_command_opts(); + + $options->grab_command_opts(args => $config_cmd_args, die_at_non_opt => 1, stop_at_non_opt => 0, passthrough => 0) + if $config_cmd_args; + + $options->grab_command_opts(); + $options->process_command_opts(); + + $options->clear_env(); + + $self->clear_env(); + + my %seen = map {((ref($_) || $_) => 1)} @{$settings->harness->plugins}; + for my $plugin (@{$options->used_plugins}) { + next if $seen{$plugin}++; + push @{$settings->harness->plugins} => $plugin->can('new') ? $plugin->new() : $plugin; + } + + return $self->{+_ARGV}; +} + +sub clear_env { + delete $ENV{HARNESS_IS_VERBOSE}; + delete $ENV{T2_FORMATTER}; + delete $ENV{T2_HARNESS_FORKED}; + delete $ENV{T2_HARNESS_IS_VERBOSE}; + delete $ENV{T2_HARNESS_JOB_IS_TRY}; + delete $ENV{T2_HARNESS_JOB_NAME}; + delete $ENV{T2_HARNESS_PRELOAD}; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_FILE}; + delete $ENV{T2_STREAM_JOB_ID}; + delete $ENV{TEST2_JOB_DIR}; + delete $ENV{TEST2_RUN_DIR}; + + # If Test2::API is already loaded then we need to keep these. + delete $ENV{TEST2_ACTIVE} unless $INC{'Test2/API.pm'}; + delete $ENV{TEST_ACTIVE} unless $INC{'Test2/API.pm'}; +} + +sub command_class { + my $self = shift; + + $self->process_argv() unless $self->{+_COMMAND_CLASS}; + + return $self->{+_COMMAND_CLASS}; +} + +sub _command_from_argv { + my $self = shift; + my %params = @_; + + return $self->{+_COMMAND_NAME} if $self->{+_COMMAND_NAME}; + + my $argv = $self->{+_ARGV}; + + for (my $idx = 0; $idx < @$argv; $idx++) { + my $arg = $argv->[$idx]; + + if ($arg =~ m/^-*h(elp)?$/i) { + splice(@$argv, $idx, 1); + return 'help'; + } + + if ($arg eq 'do') { + splice(@$argv, $idx, 1); + last; + } + + last if $arg eq '::'; + next if $arg =~ /^-/; + + if ($arg =~ m/\.jsonl(\.bz2|\.gz)?$/) { + warn "\n** First argument is a log file, defaulting to the 'replay' command **\n\n"; + return 'replay'; + } + + return splice(@$argv, $idx, 1) if $self->load_command($arg, check_only => 1); + return if $params{valid_only}; + + my $is_path = 0; + $is_path ||= -f $arg; + $is_path ||= -d $arg; + + # Assume it is a command, but an invalid one. + return splice(@$argv, $idx, 1) unless $is_path; + } + + return if $params{no_default}; + + if (my $pfile = find_pfile($self->settings, no_checks => 1)) { + warn "\n** Persistent runner detected, defaulting to the 'run' command **\n\n"; + return 'run'; + } + + warn "\n** Defaulting to the 'test' command **\n\n"; + return 'test'; +} + +sub load_command { + my $self = shift; + my ($cmd_name, %params) = @_; + + my $cmd_class = "App::Yath::Command::$cmd_name"; + my $cmd_file = "App/Yath/Command/$cmd_name.pm"; + + return $cmd_class if eval { require $cmd_file; 1 }; + my $error = $@ || 'unknown error'; + + my $not_found = $error =~ m{Can't locate \Q$cmd_file\E in \@INC}; + + return undef if $params{check_only} && $not_found; + + die "yath command '$cmd_name' not found. (did you forget to install $cmd_class?)\n" + if $not_found; + + die $error; +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath - Yet Another Test Harness (Test2-Harness) Command Line Interface +(CLI) + +=head1 DESCRIPTION + +This is the primary documentation for C<yath>, L<App::Yath>, L<Test2::Harness>. + +The canonical source of up-to-date command options are the help output when +using C<$ yath help> and C<$ yath help COMMAND>. + +This document is mainly an overview of C<yath> usage and common recipes. + +L<App::Yath> is an alternative to L<App::Prove>, and L<Test2::Harness> is an alternative to L<Test::Harness>. It is not designed to +replace L<Test::Harness>/prove. L<Test2::Harness> is designed to take full +advantage of the rich data L<Test2> can provide. L<Test2::Harness> is also able to +use non-core modules and provide more functionality than prove can achieve with +its restrictions. + +=head1 PLATFORM SUPPORT + +L<Test2::Harness>/L<App::Yath> is is focused on unix-like platforms. Most +development happens on linux, but bsd, macos, etc should work fine as well. + +Patches are welcome for any/all platforms, but the primary author (Chad +'Exodist' Granum) does not directly develop against non-unix platforms. + +=head2 WINDOWS + +Currently windows is not supported, and it is known that the package will not +install on windows. Patches are be welcome, and it would be great if someone +wanted to take on the windows-support role, but it is not a primary goal for +the project. + +=head1 OVERVIEW + +To use L<Test2::Harness>, you use the C<yath> command. Yath will find the tests +(or use the ones you specify) and run them. As it runs, it will output +diagnostic information such as failures. At the end, yath will print a summary +of the test run. + +C<yath> can be thought of as a more powerful alternative to C<prove> +(L<Test::Harness>) + +=head1 RECIPES + +These are common recipes for using C<yath>. + +=head2 RUN PROJECT TESTS + + $ yath + +Simply running yath with no arguments means "Run all tests for the current +project". Yath will look for tests in C<./t>, C<./t2>, and C<./test.pl> and +run any which are found. + +Normally this implies the C<test> command but will instead imply the C<run> +command if a persistent test runner is detected. + +=head2 PRELOAD MODULES + +Yath has the ability to preload modules. Yath normally forks to start new +tests, so preloading can reduce the time spent loading modules over and over in +each test. + +Note that some tests may depend on certain modules not being loaded. In these +cases you can add the C<# HARNESS-NO-PRELOAD> directive to the top of the test +files that cannot use preload. + +=head3 SIMPLE PRELOAD + +Any module can be preloaded: + + $ yath -PMoose + +You can preload as many modules as you want: + + $ yath -PList::Util -PScalar::Util + +=head3 COMPLEX PRELOAD + +If your preload is a subclass of L<Test2::Harness::Runner::Preload> then more +complex preload behavior is possible. See those docs for more info. + +=head2 LOGGING + +=head3 RECORDING A LOG + +You can turn on logging with a flag. The filename of the log will be printed at +the end. + + $ yath -L + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl + +The event log can be quite large. It can be compressed with bzip2. + + $ yath -B + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +gzip compression is also supported. + + $ yath -G + ... + Wrote log file: test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.gz + +C<-B> and C<-G> both imply C<-L>. + +=head3 REPLAYING FROM A LOG + +You can replay a test run from a log file: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 + +This will be significantly faster than the initial run as no tests are actually +being executed. All events are simply read from the log, and processed by the +harness. + +You can change display options and limit rendering/processing to specific test +jobs from the run: + + $ yath test-logs/2017-09-12~22:44:34~1505281474~25709.jsonl.bz2 -v [TEST UUID(S)] + +Note: This is done using the C<$ yath replay ...> command. The C<replay> +command is implied if the first argument is a log file. + +=head2 PER-TEST TIMING DATA + +The C<-T> option will cause each test file to report how long it took to run. + + $ yath -T + + ( PASSED ) job 1 t/yath_script.t + ( TIME ) job 1 Startup: 0.07692s | Events: 0.01170s | Cleanup: 0.00190s | Total: 0.09052s + +=head2 PERSISTENT RUNNER + +yath supports starting a yath session that waits for tests to run. This is very +useful when combined with preload. + +=head3 STARTING + +This starts the server. Many options available to the 'test' command will work +here but not all. See C<$ yath help start> for more info. + + $ yath start + +=head3 RUNNING + +This will run tests using the persistent runner. By default, it will search for +tests just like the 'test' command. Many options available to the C<test> +command will work for this as well. See C<$ yath help run> for more details. + + $ yath run + +=head3 STOPPING + +Stopping a persistent runner is easy. + + $ yath stop + +=head3 INFORMATIONAL + +The C<which> command will tell you which persistent runner will be used. Yath +searches for the persistent runner in the current directory, then searches in +parent directories until it either hits the root directory, or finds the +persistent runner tracking file. + + $ yath which + +The C<watch> command will tail the runner's log files. + + $ yath watch + +=head3 PRELOAD + PERSISTENT RUNNER + +You can use preloads with the C<yath start> command. In this case, yath will +track all the modules pulled in during preload. If any of them change, the +server will reload itself to bring in the changes. Further, modified modules +will be blacklisted so that they are not preloaded on subsequent reloads. This +behavior is useful if you are actively working on a module that is normally +preloaded. + +=head2 MAKING YOUR PROJECT ALWAYS USE YATH + + $ yath init + +The above command will create C<test.pl>. C<test.pl> is automatically run by +most build utils, in which case only the exit value matters. The generated +C<test.pl> will run C<yath> and execute all tests in the C<./t> and/or C<./t2> +directories. Tests in C<./t> will ALSO be run by prove but tests in C<./t2> +will only be run by yath. + +=head2 PROJECT-SPECIFIC YATH CONFIG + +You can write a C<.yath.rc> file. The file format is very simple. Create a +C<[COMMAND]> section to start the configuration for a command and then +provide any options normally allowed by it. When C<yath> is run inside your +project, it will use the config specified in the rc file, unless overridden +by command line options. + +B<Note:> You can also add pre-command options by placing them at the top of +your config file I<BEFORE> any C<[cmd]> markers. + +Comments start with a semi-colon. + +Example .yath.rc: + + -pFoo ; Load the 'foo' plugin before dealing with commands. + + [test] + -B ;Always write a bzip2-compressed log + + [start] + -PMoose ;Always preload Moose with a persistent runner + +This file is normally committed into the project's repo. + +=head3 SPECIAL PATH PSEUDO-FUNCTIONS + +Sometimes you want to specify files relative to the .yath.rc so that the config +option works from any subdirectory of the project. Other times you may wish to +use a shell expansion. Sometimes you want both! + +=over 4 + +=item rel(path/to/file) + + -I rel(path/to/extra_lib) + -I=rel(path/to/extra_lib) + +This will take the path to C<.yath.rc> and prefix it to the path inside +C<rel(...)>. If for example you have C</project/.yath.rc> then the path would +become C</project/path/to/extra_lib>. + +=item glob(path/*/file) + + --default-search glob(subprojects/*/t) + --default-search=glob(subprojects/*/t) + +This will add a C<--default-search $_> for every item found in the glob. This +uses the perl builtin function C<glob()> under the hood. + +=item relglob(path/*/file) + + --default-search relglob(subprojects/*/t) + --default-search=relglob(subprojects/*/t) + +Same as C<glob()> except paths are relative to the C<.yath.rc> file. + +=back + +=head2 PROJECT-SPECIFIC YATH CONFIG USER OVERRIDES + +You can add a C<.yath.user.rc> file. Format is the same as the regular +C<.yath.rc> file. This file will be read in addition to the regular config +file. Directives in this file will come AFTER the directives in the primary +config so it may be used to override config. + +This file should not normally be committed to the project repo. + +=head2 HARNESS DIRECTIVES INSIDE TESTS + +C<yath> will recognise a number of directive comments placed near the top of +test files. These directives should be placed after the C<#!> line but +before any real code. + +Real code is defined as any line that does not start with use, require, BEGIN, package, or # + +=over 4 + +=item good example 1 + + #!/usr/bin/perl + # HARNESS-NO-FORK + + ... + +=item good example 2 + + #!/usr/bin/perl + use strict; + use warnings; + + # HARNESS-NO-FORK + + ... + +=item bad example 1 + + #!/usr/bin/perl + + # blah + + # HARNESS-NO-FORK + + ... + +=item bad example 2 + + #!/usr/bin/perl + + print "hi\n"; + + # HARNESS-NO-FORK + + ... + +=back + +=head3 HARNESS-NO-PRELOAD + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + +Use this if your test will fail when modules are preloaded. This will tell yath +to start a new perl process to run the script instead of forking with preloaded +modules. + +Currently this implies HARNESS-NO-FORK, but that may not always be the case. + +=head3 HARNESS-NO-FORK + + #!/usr/bin/perl + # HARNESS-NO-FORK + +Use this if your test file cannot run in a forked process, but instead must be +run directly with a new perl process. + +This implies HARNESS-NO-PRELOAD. + +=head3 HARNESS-NO-STREAM + +C<yath> usually uses the L<Test2::Formatter::Stream> formatter instead of TAP. +Some tests depend on using a TAP formatter. This option will make C<yath> use +L<Test2::Formatter::TAP> or L<Test::Builder::Formatter>. + +=head3 HARNESS-NO-IO-EVENTS + +C<yath> can be configured to use the L<Test2::Plugin::IOEvents> plugin. This +plugin replaces STDERR and STDOUT in your test with tied handles that fire off +proper L<Test2::Event>'s when they are printed to. Most of the time this is not +an issue, but any fancy tests or modules which do anything with STDERR or +STDOUT other than print may have really messy errors. + +B<Note:> This plugin is disabled by default, so you only need this directive if +you enable it globally but need to turn it back off for select tests. + +=head3 HARNESS-NO-TIMEOUT + +C<yath> will usually kill a test if no events occur within a timeout (default +60 seconds). You can add this directive to tests that are expected to trip the +timeout, but should be allowed to continue. + +NOTE: you usually are doing the wrong thing if you need to set this. See: +C<HARNESS-TIMEOUT-EVENT>. + +=head3 HARNESS-TIMEOUT-EVENT 60 + +C<yath> can be told to alter the default event timeout from 60 seconds to another +value. This is the recommended alternative to HARNESS-NO-TIMEOUT + +=head3 HARNESS-TIMEOUT-POSTEXIT 15 + +C<yath> can be told to alter the default POSTEXIT timeout from 15 seconds to another value. + +Sometimes a test will fork producing output in the child while the parent is +allowed to exit. In these cases we cannot rely on the original process exit to +tell us when a test is complete. In cases where we have an exit, and partial +output (assertions with no final plan, or a plan that has not been completed) +we wait for a timeout period to see if any additional events come into + +=head3 HARNESS-DURATION-LONG + +This lets you tell C<yath> that the test file is long-running. This is +primarily used when concurrency is turned on in order to run longer tests +earlier, and concurrently with shorter ones. There is also a C<yath> option to +skip all long tests. + +This duration is set automatically if HARNESS-NO-TIMEOUT is set. + +=head3 HARNESS-DURATION-MEDIUM + +This lets you tell C<yath> that the test is medium. + +This is the default duration. + +=head3 HARNESS-DURATION-SHORT + +This lets you tell C<yath> That the test is short. + +=head3 HARNESS-CATEGORY-ISOLATION + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests. Yath will hold off and run these tests one at a time after all other +tests. + +=head3 HARNESS-CATEGORY-IMMISCIBLE + +This lets you tell C<yath> that the test cannot be run concurrently with other +tests of this class. This is helpful when you have multiple tests which would +otherwise have to be run sequentially at the end of the run. + +Yath prioritizes running these tests above HARNESS-CATEGORY-LONG. + +=head3 HARNESS-CATEGORY-GENERAL + +This is the default category. + +=head3 HARNESS-CONFLICTS-XXX + +This lets you tell C<yath> that no other test of type XXX can be run at the +same time as this one. You are able to set multiple conflict types and C<yath> +will honor them. + +XXX can be replaced with any type of your choosing. + +NOTE: This directive does not alter the category of your test. You are free +to mark the test with LONG or MEDIUM in addition to this marker. + +=head3 HARNESS-JOB-SLOTS 2 + +=head3 HARNESS-JOB-SLOTS 1 10 + +Specify a range of job slots needed for the test to run. If set to a single +value then the test will only run if it can have the specified number of slots. +If given a range the test will require at least the lower number of slots, and +use up to the maximum number of slots. + +=over 4 + +=item Example with multiple lines. + + #!/usr/bin/perl + # DASH and space are split the same way. + # HARNESS-CONFLICTS-DAEMON + # HARNESS-CONFLICTS MYSQL + + ... + +=item Or on a single line. + + #!/usr/bin/perl + # HARNESS-CONFLICTS DAEMON MYSQL + + ... + +=back + +=head3 HARNESS-RETRY-n + +This lets you specify a number (minimum n=1) of retries on test failure +for a specific test. HARNESS-RETRY-1 means a failing test will be run twice +and is equivalent to HARNESS-RETRY. + +=head3 HARNESS-NO-RETRY + +Use this to avoid this test being retried regardless of your retry settings. + +=head1 MODULE DOCS + +This section documents the L<App::Yath> module itself. + +=head2 SYNOPSIS + +In practice you should never need to write your own yath script, or construct +an L<App::Yath> instance, or even access themain instance when yath is running. +However some aspects of doing so are documented here for completeness. + +A minimum yath script looks like this: + + BEGIN { + package App::Yath:Script; + + require Time::HiRes; + require App::Yath; + require Test2::Harness::Settings; + + my $settings = Test2::Harness::Settings->new( + harness => { + orig_argv => [@ARGV], + orig_inc => [@INC], + script => __FILE__, + start => Time::HiRes::time(), + version => $App::Yath::VERSION, + }, + ); + + my $app = App::Yath->new( + argv => \@ARGV, + config => {}, + settings => $settings, + ); + + $app->generate_run_sub('App::Yath::Script::run'); + } + + exit(App::Yath::Script::run()); + +It is important that most logic live in a BEGIN block. This is so that +L<goto::file> can be used post-fork to execute a test script. + +The actual yath script is significantly more complicated with the following behaviors: + +=over 4 + +=item pre-process essential arguments such as -D and no-scan-plugins + +=item re-exec with a different yath script if in developer mode and a local copy is found + +=item Parse the yath-rc config files + +=item gather and store essential startup information + +=back + +=head2 METHODS + +App::Yath does not provide many methods to use externally. + +=over 4 + +=item $app->generate_run_sub($symbol_name) + +This tells App::Yath to generate a subroutine at the specified symbol name +which can be run and be expected to return an exit value. + +=item $lib_path = $app->app_path() + +Get the include directory App::Yath was loaded from. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Command.pm b/liby/App/Yath/Command.pm new file mode 100644 index 000000000..4f49190af --- /dev/null +++ b/liby/App/Yath/Command.pm @@ -0,0 +1,383 @@ +package App::Yath::Command; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Carp qw/croak/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::HashBase qw/-settings -args/; + +use App::Yath::Options(); + +use Test2::Harness::Util::File::JSON(); + +sub internal_only { 0 } +sub always_keep_dir { 0 } +sub summary { "No Summary" } +sub description { "No Description" } +sub group { "Z-UNFINISHED" } +sub doc_args { () } +sub only_cmd_opts { 0 } + +sub handle_invalid_option { 0 } + +sub munge_opts { } + +sub name { $_[0] =~ m/([^:=]+)(?:=.*)?$/; $1 || $_[0] } + +sub run { + my $self = shift; + + warn "This command is currently empty"; + + return 1; +} + +sub cli_help { + my $class = shift; + my %params = @_; + + my $settings = $params{settings} // {}; + my $script = $settings->harness->script // $0; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = $params{options}; + unless ($options) { + $options = App::Yath::Options->new; + $options->set_command_class($class); + } + + my ($pre_opts, $cmd_opts); + if ($options) { + $pre_opts = $options->pre_docs('cli'); + $cmd_opts = $options->cmd_docs('cli'); + } + + my $usage = "Usage: $script"; + + my @out; + + if ($pre_opts) { + $usage .= ' [YATH OPTIONS]'; + + $pre_opts =~ s/^/ /mg; + push @out => "[YATH OPTIONS]\n$pre_opts"; + } + + $usage .= " $cmd"; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + + $cmd_opts =~ s/^/ /mg; + push @out => "[COMMAND OPTIONS]\n$cmd_opts"; + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + my @desc; + for my $arg (@args) { + if (ref($arg)) { + my ($name, $text) = @$arg; + push @desc => $name; + $text =~ s/^/ /mg; + push @desc => "$text\n"; + } + else { + push @desc => "$arg\n"; + } + } + + my $desc = join "\n" => @desc; + $desc =~ s/^/ /mg; + + push @out => "[COMMAND ARGUMENTS]\n$desc"; + } + + chomp(my $desc = $class->description); + unshift @out => ("$cmd - " . $class->summary, $desc, $usage); + + return join("\n\n" => grep { $_ } @out) . "\n"; +} + +sub generate_pod { + my $class = shift; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = App::Yath::Options->new(); + require App::Yath; + my $ay = App::Yath->new(); + $options->include($ay->load_options); + $options->set_command_class($class); + my $pre_opts = $options->pre_docs('pod', 3); + my $cmd_opts = $options->cmd_docs('pod', 3); + + my $usage = " \$ yath [YATH OPTIONS] $cmd"; + + my @head2s; + + push @head2s => ("=head2 YATH OPTIONS", $pre_opts) if $pre_opts; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + push @head2s => ("=head2 COMMAND OPTIONS", $cmd_opts); + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + push @head2s => ( + "=head2 COMMAND ARGUMENTS", + "=over 4", + (map { ref($_) ? ( "=item $_->[0]", $_->[1] ) : ("=item $_") } @args), + "=back" + ); + } + + my @out = ( + "=head1 NAME", + "$class - " . $class->summary, + "=head1 DESCRIPTION", + $class->description, + "=head1 USAGE", + $usage, + @head2s + ); + + return join("\n\n" => grep { $_ } @out); +} + +sub setup_resources { + my $self = shift; + my $settings = $self->settings; + + return unless $settings->check_prefix('runner'); + my $runner = $settings->runner; + my $res = $runner->resources or return; + return unless @$res; + + for my $res (@$res) { + require(mod2file($res)) unless ref $res; + $res->setup($settings); + } +} + +sub setup_plugins { + my $self = shift; + $_->setup($self->settings) for @{$self->settings->harness->plugins}; +} + +sub teardown_plugins { + my $self = shift; + my ($renderers, $logger) = @_; + $_->teardown($self->settings, $renderers, $logger) for @{$self->settings->harness->plugins}; +} + +sub finalize_plugins { + my $self = shift; + $_->finalize($self->settings) for @{$self->settings->harness->plugins}; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Command - Base class for yath commands + +=head1 DESCRIPTION + +This is the base class for any/all yath commands. If you wish to add a new yath +command you should subclass this package. + +=head1 SYNOPSIS + + package App::Yath::Command::mycommand; + use strict; + use warnings; + + use App::Yath::Options(); + use parent 'App::Yath::Command'; + + # Include existing option sets + include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + ..., + ); + + # Add some custom options + option_group {prefix => 'mycommand', category => 'mycommand options'} => sub { + option foo => ( + description => "the foo option", + default => 0, + ); + }; + + # This is used to sort/group commands in the "yath help" output + sub group { 'thirdparty' } + + # Brief 1-line summary + sub summary { "This is a third party command, it does stuff..." } + + # Longer description of the command (used in yath help mycommand) + sub description { + return <<" EOT"; + This command does: + This + That + Those + EOT + } + + # Entrypoint + sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + print "Hello Third Party!\n" + + # Return an exit value. + return 0; + } + +=head1 CLASS METHODS + +=over 4 + +=item $string = $cmd_class->cli_help(settings => $settings, options => $options) + +This method generates the command line help for any given command. In general +you will NOT want to override this. + +$settings should be an instance of L<Test2::Harness::Settings>. + +$options should be an instance of L<App::Yath::Options> if provided. This +method is usually capable of filling in the details when this is omitted. + +=item $multi_line_string = $cmd_class->description() + +Long-form description of the command. Used in C<cli_help()>. + +=item @list = $cmd_class->doc_args() + +A list of argument names to the command, used to generate documentation. + +=item $string = $cmd_class->generate_pod() + +This can be used to generate POD documentation from the command itself using +the other fields listed in this section, as well as all applicable command +lines options specified in the command. + +=item $string = $cmd_class->group() + +Used for sorting/grouping commands in the C<yath help> output. + +Existing groups: + + ' test' # Space in front to make sure test related command float up + 'log' # Log processing commands + 'persist' # Commands related to the persistent runner + 'zinit' # The init command and related command sink to the bottom. + +Unless your command OBVIOUSLY and CLEARLY belongs in one of the above groups +you should probably create your own. Please do not prefix it with a space to +make it float, C<' test'> is a special case, you are not that special. + +=item $string = $cmd_class->name() + +Name of the command. By default this is the last part of the package name. You +will probably never want to override this. + +=item $short_string = $cmd_class->summary() + +A short summary of what this command is. + +=back + +=head1 OBJECT METHODS + +=over 4 + +=item $bool = $cmd->always_keep_dir() + +By default the working directory is deleted when yath exits. Some commands such +as L<App::Yath::Command::start> need to keep the directory. Override this +method to return true if your command uses the workdir and needs to keep it. + +=item $arrayref = $cmd->args() + +Get an arrayref of command line arguments B<AFTER> options have been +process/removed. + +=item $bool = $cmd->internal_only() + +Set this to true if you do not want your command to show up in the help output. + +=item $exit_code = $cmd->run() + +This is the main entrypoint for the command. You B<MUST> override this. This +method should return an exit code. + +=item $settings = $cmd->settings() + +Get the settings as populated by the command line options. + +=item $cmd->write_settings_to($directory, $filename) + +A helper method to write the settings to a specified directory and filename. +File is written as JSON. + +If you are subclassing another command such as L<App::Yath::Command::test> you +may want to override this to a no-op to prevent the settings file from being +written, the L<App::Yath::Command:run> command does this. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Command/abort.pm b/liby/App/Yath/Command/abort.pm new file mode 100644 index 000000000..349002f9a --- /dev/null +++ b/liby/App/Yath/Command/abort.pm @@ -0,0 +1,68 @@ +package App::Yath::Command::abort; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; +use Term::Table; + +use File::Spec(); + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command::status'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Abort all currently running or queued tests without killing the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will kill all running tests and clear the queue, but will not close the runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + # Get the output from finding the pfile + $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + print "\nTruncating Queue...\n\n"; + $state->truncate; + $state->poll; + + my $running = $state->running_tasks; + for my $task (values %$running) { + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next;; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + + print "\n"; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/aggregator.pm b/liby/App/Yath/Command/aggregator.pm new file mode 100644 index 000000000..99e6834b8 --- /dev/null +++ b/liby/App/Yath/Command/aggregator.pm @@ -0,0 +1,46 @@ +package App::Yath::Command::aggregator; +use strict; +use warnings; + +use Test2::Harness::Aggregator; +use Test2::Harness::State; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +our $VERSION = '2.000000'; + +sub name { 'aggregator' } +sub group { 'z_internal' } +sub summary { "Start an aggregator process" } +sub internal_only { 1 } + +sub description { + return <<" EOT"; +An aggregator process takes events from any number of sources and combines them +into a single output stream. + EOT +} + +sub run { + my $self = shift; + my ($name, $state_file, $fifo_file, $output_file, $parent_pid) = @{$self->{+ARGS}}; + + my $state = Test2::Harness::State->new(state_file => $state_file); + + my $aggregator = Test2::Harness::Aggregator->new( + name => $name, + state => $state, + fifo_file => $fifo_file, + output_file => $output_file, + ); + + return $aggregator->run($parent_pid); +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/auditor.pm b/liby/App/Yath/Command/auditor.pm new file mode 100644 index 000000000..963840478 --- /dev/null +++ b/liby/App/Yath/Command/auditor.pm @@ -0,0 +1,58 @@ +package App::Yath::Command::auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Scalar::Util qw/blessed/; + +use App::Yath::Util qw/isolate_stdout/; + +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Run; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'auditor' } + +sub run { + my $self = shift; + my ($auditor_class, $run_id, %args) = @{$self->{+ARGS}}; + + my $name = 'yath-auditor'; + $name = "$args{procname_prefix}-${name}" if $args{procname_prefix}; + $0 = $name; + + my $fh = isolate_stdout(); + + require(mod2file($auditor_class)); + + my $auditor = $auditor_class->new( + %args, + run_id => $run_id, + action => sub { print $fh defined($_[0]) ? blessed($_[0]) ? $_[0]->as_json . "\n" : encode_json($_[0]) . "\n" : "null\n" }, + ); + + local $SIG{PIPE} = 'IGNORE'; + my $ok = eval { $auditor->process(); 1 }; + my $err = $@; + + eval { $auditor->finish(); 1 } or warn $@; + + die $err unless $ok; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/collector.pm b/liby/App/Yath/Command/collector.pm new file mode 100644 index 000000000..325dc41c9 --- /dev/null +++ b/liby/App/Yath/Command/collector.pm @@ -0,0 +1,167 @@ +package App::Yath::Command::collector; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Time::HiRes qw/sleep time/; +use Test2::Harness::Util qw/fqmod clean_path/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +include_options( + 'App::Yath::Options::Debug', +); + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'collector' } + +option_group {prefix => 'collector', category => 'collector options'} => sub { + option parser => ( + type => 's', + default => 'Test2::Harness::Collector::IOParser', + description => "The parser to use when reading from stderr and stdout.", + long_examples => [' IOParser', ' StreamParser'], + short_examples => [' IOParser', ' StreamParser'], + normalize => sub { fqmod('Test2::Harness::Collector', $_[0]) }, + ); + + option aggregator => ( + type => 's', + description => "What aggregator should receive the events (also requires a state file)", + long_examples => [' runner', ' renderer'], + short_examples => [' runner', ' renderer'], + ); + + option aggregator_timeout => ( + type => 's', + description => 'Timeout when waiting for the aggregator to show up in the state file', + default => 10, + long_examples => [' 10'], + short_examples => [' 10'], + ); + + option state_file => ( + type => 's', + description => "State file for the yath instance", + long_examples => [' /path/to/statefile'], + short_examples => [' /path/to/statefile'], + normalize => \&clean_path, + ); + + option output_file => ( + type => 's', + description => "Output file to use instead of an aggregator or stdout", + long_examples => [' /path/to/output.jsonl'], + short_examples => [' /path/to/output.jsonl'], + normalize => \&clean_path, + ); + + option run_id => ( + type => 's', + default => 0, + description => 'Run ID to use for parsed events', + ); + + option job_id => ( + type => 's', + default => 0, + description => 'Job ID to use for parsed events', + ); + + option parent_pid => ( + type => 's', + default => sub { getppid() }, + description => 'Pid of parent process', + ); +}; + +sub writer { + my $self = shift; + + my $settings = $self->settings; + + if (my $agg = $settings->collector->aggregator) { + my $state_file = $settings->collector->state_file or die "'state_file' is a required argument when specifying an aggregator.\n"; + my $state = Test2::Harness::State->new(state_file => $state_file); + + my $timeout = $settings->collector->aggregator_timeout; + my $start = time; + my $agg_data; + + while (!$agg_data) { + $state->transaction(r => sub { + my ($state, $data) = @_; + $agg_data = $data->aggregators->{$agg}; + }); + + die "Timed out waiting for aggregator ($agg) after $timeout seconds.\n" if (time - $start) > $timeout; + sleep 0.2 unless $agg_data; + } + + require Atomic::Pipe; + my $w = Atomic::Pipe->write_fifo($agg_data->{fifo}); + + return sub { $w->write_message(encode_json($_[0])) }; + } + + if (my $out_file = $settings->collector->output_file) { + require Test2::Harness::Util::File::JSONL; + my $of = Test2::Harness::Util::File::JSONL->new(name => $out_file); + return sub { $of->write($_[0]) }; + } + + return sub { print STDOUT encode_json($_[0]), "\n" }; +} + +sub run { + my $self = shift; + my @exec = @{$self->args // []}; + shift @exec while @exec && $exec[0] eq '--'; + + my $writer = $self->writer; + + # Init the stream parser + # Start the child + # read-parse-send output from child + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + + +yath collect "json spec" { +parser => Parser::Module, +aggregator_name => NAME, +state_file => path, +exec => [command], +job_id (or 0) +run_id (or 0) +...? +} + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($class, $args) = @$norm; + + $class = "Test2::Harness::Renderer::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + my $ok = eval { require $file; 1 }; + warn "Failed to load renderer '$class': $@" unless $ok; + + $handler->($slot, [$class, $args]); + }, + diff --git a/liby/App/Yath/Command/do.pm b/liby/App/Yath/Command/do.pm new file mode 100644 index 000000000..d4535b491 --- /dev/null +++ b/liby/App/Yath/Command/do.pm @@ -0,0 +1,41 @@ +package App::Yath::Command::do; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::File::JSON; + +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { '' } + +sub summary { "Run tests using 'run' or 'test', same as the default command, but explicit." } +sub cli_args { "[run or test args]" } + +sub description { + return <<" EOT"; +This is the same as running yath without a command, except that it will not +fail on CLI parsing issues that often get mistaken for commands. + +If there is a persistent runner then the 'run' command is used, otherwise the +'test' command is used. + EOT +} + +sub run { + # This file is actually just a stub for the magic of 'do'. Code is not executed. + die "This should not be reachable"; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + + diff --git a/liby/App/Yath/Command/failed.pm b/liby/App/Yath/Command/failed.pm new file mode 100644 index 000000000..ff05e3681 --- /dev/null +++ b/liby/App/Yath/Command/failed.pm @@ -0,0 +1,147 @@ +package App::Yath::Command::failed; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Table qw/table/; +use Test2::Harness::Util::File::JSONL; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw{<log_file}; + +use App::Yath::Options; + +option brief => ( + prefix => 'display', + category => 'Display Options', + description => 'Show only the files that failed, newline separated, no other output. If a file failed once but passed on a retry it will NOT be shown.', +); + +sub summary { "Show the failed tests from an event log" } + +sub group { 'log' } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [job1, job2, ...]" } + +sub description { + return <<" EOT"; +This yath command will list the test scripts from an event log that have failed. +The only required argument is the path to the log file, which may be compressed. +Any extra arguments are assumed to be job id's. If you list any jobs, +only the listed jobs will be processed. + +This command accepts all the same renderer/formatter options that the 'test' +command accepts. + EOT +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my %failed; + + while(1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + push @{$failed{$job_id}->{subtests}} => $self->subtests($f) + if $f->{parent} && !$f->{trace}->{nested} && $self->include_subtest($f); + + next unless $f->{harness_job_end}; + next unless $f->{harness_job_end}->{fail} || $failed{$job_id}; + + push @{$failed{$job_id}->{ends}} => $f->{harness_job_end}; + } + } + + my $rows = []; + while (my ($job_id, $data) = each %failed) { + my $ends = $data->{ends} // []; + + my %seen; + my $subtests = join "\n" => grep { !$seen{$_}++ } sort @{$data->{subtests} // []}; + + if ($settings->display->brief) { + print $ends->[-1]->{rel_file}, "\n" if $ends->[-1]->{fail}; + } + else { + push @$rows => [$job_id, scalar(@$ends), $ends->[-1]->{rel_file}, $subtests, $ends->[-1]->{fail} ? "NO" : "YES"]; + } + } + + return 0 if $settings->display->brief; + + unless (@$rows) { + print "\nNo jobs failed!\n"; + return 0; + } + + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Times Run', 'Test File', "Subtests", "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + + return 0; +} + +sub include_subtest { + my $self = shift; + my ($f) = @_; + + return 0 unless $f->{parent} && keys %{$f->{parent}}; + return 0 if $f->{assert}->{pass} || !keys %{$f->{assert}}; + return 0 if $f->{amnesty} && @{$f->{amnesty}}; + return 1; +} + +sub subtests { + my $self = shift; + my ($f, $prefix) = @_; + + return unless $self->include_subtest($f); + + my $name = $f->{assert}->{details}; + unless ($name) { + my $frame = $f->{trace}->{frame}; + $name = "Unnamed Subtest"; + $name .= " ($frame->[1] line $frame->[2])" if $frame->[1] && $frame->[2]; + } + + $name = "$prefix -> $name" if $prefix; + + my @out; + push @out => $name; + for my $child (@{$f->{parent}->{children}}) { + next unless $child->{parent}; + push @out => $self->subtests($child, $name); + } + + return @out; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/help.pm b/liby/App/Yath/Command/help.pm new file mode 100644 index 000000000..ff1224c98 --- /dev/null +++ b/liby/App/Yath/Command/help.pm @@ -0,0 +1,96 @@ +package App::Yath::Command::help; +use strict; +use warnings; + +use Test2::Util qw/pkg_to_file/; + +our $VERSION = '1.000152'; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/<_command_info_hash/; + +use Test2::Harness::Util qw/open_file find_libraries/; +use List::Util (); + +sub options {}; +sub group { '' } +sub summary { 'Show the list of commands' } + +sub description { + return <<" EOT" +This command provides a list of commands when called with no arguments. +When given a command name as an argument it will print the help for that +command. + EOT +} + +sub command_info_hash { + my $self = shift; + + return $self->{+_COMMAND_INFO_HASH} if $self->{+_COMMAND_INFO_HASH}; + + my %commands; + my $command_libs = find_libraries('App::Yath::Command::*'); + for my $lib (sort keys %$command_libs) { + my $ok = eval { require $command_libs->{$lib}; 1 }; + unless ($ok) { + warn "Failed to load command '$command_libs->{$lib}': $@"; + next; + } + + next if $lib->internal_only; + my $name = $lib->name; + my $group = $lib->group; + $commands{$group}->{$name} = $lib->summary; + } + + return $self->{+_COMMAND_INFO_HASH} = \%commands; +} + +sub command_list { + my $self = shift; + + my $command_hash = $self->command_info_hash(); + my @commands = map keys %$_, values %$command_hash; + return @commands; +} + +sub run { + my $self = shift; + my $args = $self->{+ARGS}; + + return $self->command_help($args->[0]) if @$args; + + my $script = $self->settings->harness->script // $0; + my $maxlen = List::Util::max(map length, $self->command_list); + + print "\nUsage: $script COMMAND [options]\n\nAvailable Commands:\n"; + + my $command_info_hash = $self->command_info_hash; + for my $group (sort keys %$command_info_hash) { + my $set = $command_info_hash->{$group}; + + printf(" %${maxlen}s: %s\n", $_, $set->{$_}) for sort keys %$set; + print "\n"; + } + + return 0; +} + +sub command_help { + my $self = shift; + my ($command) = @_; + + require App::Yath; + my $cmd_class = App::Yath->load_command($command); + print $cmd_class->cli_help(settings => $self->{+SETTINGS}); + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/init.pm b/liby/App/Yath/Command/init.pm new file mode 100644 index 000000000..abb282703 --- /dev/null +++ b/liby/App/Yath/Command/init.pm @@ -0,0 +1,66 @@ +package App::Yath::Command::init; +use strict; +use warnings; + +use parent 'App::Yath::Command'; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/open_file/; +use App::Yath::Util qw/is_generated_test_pl/; + +sub group { 'zinit' } + +sub summary { "Create/update test.pl to run tests via Test2::Harness" } + +sub description { + return <<" EOT"; +This command will create or update the 'test.pl' file in the current directory. +This 'test.pl' file this creates will run all your tests via yath. + +This command will fail if there is already a test.pl file that does not look +like it was generated by this command. + EOT +} + +sub run { + die "'test.pl' already exists, and does not appear to be a yath runner.\n" + if -f 'test.pl' && !is_generated_test_pl('test.pl'); + + print "\nWriting test.pl...\n\n"; + + my $fh = open_file('test.pl', '>'); + + print $fh <<' EOT'; +#!/usr/bin/env perl +# HARNESS-NO-PRELOAD +# HARNESS-CAT-LONG +# THIS IS A GENERATED YATH RUNNER TEST +use strict; +use warnings; + +use lib 'lib'; +use App::Yath::Util qw/find_yath/; + +system($^X, find_yath(), '-D', 'test', '--default-search' => './t', '--default-search' => './t2', @ARGV); +my $exit = $?; + +# This makes sure it works with prove. +print "1..1\n"; +print "not " if $exit; +print "ok 1 - Passed tests when run by yath\n"; +print STDERR "yath exited with $exit" if $exit; + +exit($exit ? 255 : 0); + EOT + + return 0; +} + +1; + + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/kill.pm b/liby/App/Yath/Command/kill.pm new file mode 100644 index 000000000..ebb379bc6 --- /dev/null +++ b/liby/App/Yath/Command/kill.pm @@ -0,0 +1,54 @@ +package App::Yath::Command::kill; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; +use App::Yath::Util qw/find_pfile/; +use File::Path qw/remove_tree/; + +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::abort'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Kill the runner and any running or pending tests" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will kill the active yath runner and any running or pending tests. + EOT +} + +sub pfile_params { (no_checks => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + my $pfile = $data->{pfile_path}; + + $self->App::Yath::Command::test::terminate_queue(); + + $_->teardown($self->settings) for @{$self->settings->harness->plugins}; + + $self->SUPER::run(); + + sleep(0.02) while kill(0, $self->pfile_data->{pid}); + unlink($pfile) if -f $pfile; + remove_tree($self->workdir, {safe => 1, keep_root => 0}) if -d $self->workdir; + print "\n\nRunner stopped\n\n" unless $self->settings->display->quiet; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/one.pm b/liby/App/Yath/Command/one.pm new file mode 100644 index 000000000..9ed1a8a2f --- /dev/null +++ b/liby/App/Yath/Command/one.pm @@ -0,0 +1,790 @@ +package App::Yath::Command::one; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Event; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Runner::State; + +use Test2::Harness::Util::JSON qw/encode_json decode_json JSON/; +use Test2::Harness::Util qw/mod2file open_file chmod_tmp/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + +use File::Spec; +use Fcntl(); + +use Time::HiRes qw/sleep time/; +use List::Util qw/sum max min/; +use Carp qw/croak/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/ + <run_id +/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Workspace', +); + +sub MAX_ATTACH() { 1_048_576 } + +sub group { ' test' } + +sub summary { "Run a single test" } +sub cli_args { '[--] test files [::] [arguments to test script]' } + +sub description { + return <<" EOT"; +Run a single test with minimal framework. This skips the preloads, runner, etc. + EOT +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); +} + +sub workdir { + my $self = shift; + $self->settings->workspace->workdir; +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $plugins = $self->settings->harness->plugins; + + if ($self->start()) { + $self->render(); + $self->stop(); + + my $final_data = $self->{+FINAL_DATA} or die "Final data never received from auditor!\n"; + my $pass = $self->{+TESTS_SEEN} && $final_data->{pass}; + $self->render_final_data($final_data); + $self->produce_summary($pass); + + if (@$plugins) { + my %args = ( + settings => $settings, + final_data => $final_data, + pass => $pass ? 1 : 0, + tests_seen => $self->{+TESTS_SEEN} // 0, + asserts_seen => $self->{+ASSERTS_SEEN} // 0, + ); + $_->finish(%args) for @$plugins; + } + + return $pass ? 0 : 1; + } + + $self->stop(); + + return 1; +} + +sub DESTROY { + my $self = shift; + + local ($?, $!, $@, $_); + + my $cleanup = delete $self->{+CLEANUP_SUBS} or return; + for my $sub (@$cleanup) { + eval { $sub->(); 1 } or warn $@; + } +} + +sub write_test_info { + my $self = shift; + + return if $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO}; + + my $info_file = "./.test_info.$$.json"; + + my $workdir = $self->workdir; + Test2::Harness::Util::File::JSON->new(name => $info_file)->write({ + workdir => $self->workdir, + job_count => $self->job_count, + }); + + push @{$self->{+CLEANUP_SUBS}} => sub { + return unless -e $info_file; + return unless Test2::Harness::Util::File::JSON->new(name => $info_file)->read->{workdir} eq $workdir; + unlink($info_file) or die "Could not unlink info file: $!"; + }; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} = 1; +} + +sub start { + my $self = shift; + + $self->all_state->transaction(w => sub { 1 }); + + $self->ipc->start(); + $self->parse_args; + + $self->write_test_info(); + my $pop = $self->populate_queue(); + $self->terminate_queue(); + + return unless $pop; + + $self->setup_plugins(); + $self->setup_resources(); + + $self->start_runner(jobs_todo => $pop); + $self->start_collector(); + $self->start_auditor(); + + return 1; +} + +sub render { + my $self = shift; + + my $ipc = $self->ipc; + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + my $plugins = $self->settings->harness->plugins; + + my $handle_plugins = [grep { $_->can('handle_event') } @$plugins]; + my $annotate_plugins = [grep { $_->can('annotate_event') } @$plugins]; + + # render results from log + my $reader = $self->renderer_reader(); + $reader->blocking(0); + my $buffer; + while (1) { + return if $self->{+SIGNAL}; + $_->step for @{$renderers}; + + my $line = <$reader>; + unless(defined $line) { + $ipc->wait() if $ipc; + sleep 0.02; + next; + } + + if ($buffer) { + $line = $buffer . $line; + $buffer = undef; + } + + unless (substr($line, -1, 1) eq "\n") { + $buffer //= ""; + $buffer .= $line; + next; + } + + my $e = decode_json($line); + + if (defined $e) { + bless($e, 'Test2::Harness::Event'); + my $fd = $e->{facet_data} //= {}; + + my $changed = 0; + for my $p (@$annotate_plugins) { + my %inject = $p->annotate_event($e, $settings); + next unless keys %inject; + $changed++; + + # Can add new facets, but not modify existing ones. + # Someone could force the issue by modifying the event directly + # inside 'annotate_event', this is not supported, but also not + # forbidden, user beware. + for my $f (keys %inject) { + if (exists $fd->{$f}) { + if ('ARRAY' eq ref($fd->{$f})) { + push @{$fd->{$f}} => @{$inject{$f}}; + } + else { + warn "Plugin '$p' tried to add facet '$f' via 'annotate_event()', but it is already present and not a list, ignoring plugin annotation.\n"; + } + } + else { + $fd->{$f} = $inject{$f}; + } + } + + } + + if ($logger) { + if ($changed) { + my $newline = $e->as_json; + print $logger $newline, "\n"; + } + else { + print $logger $line; + } + } + } + else { + last; + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + $_->render_event($e) for @$renderers; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + $_->handle_event($e, $settings) for @$handle_plugins; + + $ipc->wait() if $ipc; + } +} + +sub get_job_pid { + my $self = shift; + my ($run_id, $job_id) = @_; + + return undef unless $run_id && $job_id; + + my $jdata = $self->{+ALL_STATE}->data->jobs->{$self->{+RUN_ID}} or return undef; + my $list = $jdata->{list} or return undef; + + my $found; + for my $task (@$list) { + next unless $task->{job_id} && $task->{job_id} eq $job_id; + $found = $task; + # Do not end loop early, we want the last matching entry in cases of re-run + } + + return undef unless $found; + + return $found->{pid} // undef; +} + +sub stop { + my $self = shift; + + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + + $self->teardown_plugins($renderers, $logger); + if ($logger) { + print $logger "null\n"; + close($logger); + } + + $_->finish() for @$renderers; + + my $ipc = $self->ipc; + print STDERR "Waiting for child processes to exit...\n" if $self->{+SIGNAL}; + + if ($self->{+SIGNAL}) { + my $state = $self->state; + delete $state->{no_poll}; + $state->poll; + my $running = $state->running_tasks; + $state->halt_run($self->{+RUN_ID}); + + for my $task (values %$running) { + next unless $task->{run_id} && $task->{run_id} eq $self->{+RUN_ID}; + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + } + + $ipc->wait(all => 1); + $ipc->stop; + + unless ($settings->display->quiet > 2) { + printf STDERR "\nNo tests were seen!\n" unless $self->{+TESTS_SEEN}; + + printf("\nKeeping work dir: %s\n", $self->workdir) + if $settings->debug->keep_dirs; + + if ($settings->logging->log) { + print "\n"; + print "Wrote log file: " . $settings->logging->log_file . "\n"; + print " (Symlinked to: " . $self->{+LAST_LOG} . ")\n"; + } + + $self->finalize_plugins(); + } +} + +sub terminate_queue { + my $self = shift; + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + $queue->{$_}->{closed} = 1 for keys %$queue; + }); + + $self->state->end_queue(); +} + +sub build_run { + my $self = shift; + + return $self->{+RUN} if $self->{+RUN}; + + my $settings = $self->settings; + my $dir = $self->workdir; + + my $run = $settings->build(run => 'Test2::Harness::Run'); + + mkdir($run->run_dir($dir)) or die "Could not make run dir: $!"; + chmod_tmp($dir); + + return $self->{+RUN} = $run; +} + +sub all_state { + my $self = shift; + + $self->{+ALL_STATE} //= Test2::Harness::State->new( + workdir => $self->workdir, + job_count => $self->job_count, + settings => $self->settings, + ); +} + +sub state { + my $self = shift; + + my $all_state = $self->all_state; + + $self->{+STATE} //= Test2::Harness::Runner::State->new( + state => $all_state, + workdir => $self->workdir, + job_count => $self->job_count, + no_poll => 1, + ); +} + +sub job_count { + my $self = shift; + + return $self->settings->runner->job_count; +} + +sub finder_args {()} + +sub populate_queue { + my $self = shift; + + my $run = $self->build_run(); + $self->{+RUN_ID} = $run->run_id; + my $settings = $self->settings; + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + + my $state = $self->state; + my $plugins = $settings->harness->plugins; + + $state->queue_run($run->queue_item($plugins)); + + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my @add_to_queue; + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + $state->queue_task($task); + + push @add_to_queue => $task; + } + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + push @{$queue->{$self->{+RUN_ID}}->{list} //= []} => @add_to_queue; + }); + + $state->stop_run($run->run_id); + + return $job_count; +} + +sub produce_summary { + my $self = shift; + my ($pass) = @_; + + my $settings = $self->settings; + + my $time_data = { + start => $settings->harness->start, + stop => time(), + }; + + $time_data->{wall} = $time_data->{stop} - $time_data->{start}; + + my @times = times(); + @{$time_data}{qw/user system cuser csystem/} = @times; + $time_data->{cpu} = sum @times; + + my $cpu_usage = int($time_data->{cpu} / $time_data->{wall} * 100); + + $self->write_summary($pass, $time_data, $cpu_usage); + $self->render_summary($pass, $time_data, $cpu_usage); +} + +sub write_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + my $file = $self->settings->debug->summary or return; + + my $final_data = $self->{+FINAL_DATA}; + + my $failures = @{$final_data->{failed} // []}; + + my %data = ( + %$final_data, + + pass => $pass ? JSON->true : JSON->false, + + total_failures => $failures // 0, + total_tests => $self->{+TESTS_SEEN} // 0, + total_asserts => $self->{+ASSERTS_SEEN} // 0, + + cpu_usage => $cpu_usage, + + times => $time_data, + ); + + require Test2::Harness::Util::File::JSON; + my $jfile = Test2::Harness::Util::File::JSON->new(name => $file); + $jfile->write(\%data); + + print "\nWrote summary file: $file\n\n"; + + return; +} + +sub render_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + return if $self->settings->display->quiet > 1; + + my $final_data = $self->{+FINAL_DATA}; + my $failures = @{$final_data->{failed} // []}; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $self->{+TESTS_SEEN}", + "Assertion Count: $self->{+ASSERTS_SEEN}", + $time_data ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->settings->display->color && USE_ANSI_COLOR) { + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + +sub render_final_data { + my $self = shift; + my ($final_data) = @_; + + return if $self->settings->display->quiet > 1; + + if (my $rows = $final_data->{retried}) { + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + header => ['Job ID', 'Times Run', 'Test File', "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{failed}) { + print "\nThe following jobs failed:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Test File', 'Subtests'], + rows => [map { my $r = [@{$_}]; $r->[2] = stringify_subtest_map($r->[2]) if $r->[2]; $r} @$rows], + ); + print "\n"; + } + + if (my $rows = $final_data->{halted}) { + print "\nThe following jobs requested all testing be halted:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File', "Reason"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{unseen}) { + print "\nThe following jobs never ran:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File'], + rows => $rows, + ); + print "\n"; + } +} + +sub stringify_subtest_map { + my ($map) = @_; + + my $out = ""; + my @todo = @$map; + my @state; + while (my $st = shift @todo) { + if (!ref($st)) { + pop @state if $st eq 'pop'; + next; + } + push @state => $st->[0]; + $out .= join(' -> ' => @state) . "\n"; + unshift @todo => (@{$st->[1]}, 'pop'); + } + + return $out; +} + +sub logger { + my $self = shift; + + return $self->{+LOGGER} if $self->{+LOGGER}; + + my $settings = $self->{+SETTINGS}; + + return unless $settings->logging->log; + + my $file = $settings->logging->log_file; + + if ($settings->logging->bzip2) { + no warnings 'once'; + require IO::Compress::Bzip2; + $self->{+LOGGER} = IO::Compress::Bzip2->new($file) or die "Could not open log file '$file': $IO::Compress::Bzip2::Bzip2Error"; + } + elsif ($settings->logging->gzip) { + no warnings 'once'; + require IO::Compress::Gzip; + $self->{+LOGGER} = IO::Compress::Gzip->new($file) or die "Could not open log file '$file': $IO::Compress::Gzip::GzipError"; + } + else { + $self->{+LOGGER} = open_file($file, '>'); + } + + for my $ext ('jsonl', 'jsonl.bz2', 'jsonl.gz') { + my $name = "./lastlog.$ext"; + next unless -f $name; + local ($!, $@) = (0, ''); + eval { unlink($name) } or warn "Could not unlink '$name': ($!) $@"; + } + + if ($file =~ m/\.(jsonl(?:\.(?:bz2|gz))?)$/) { + my $ext = $1; + my $name = "./lastlog.$ext"; + if (eval { symlink($file, $name); 1 }) { + $self->{+LAST_LOG} = $name; + } + else { + warn "Could not symlink the log file to '$name': $@"; + } + } + + return $self->{+LOGGER}; +} + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + my @renderers; + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub start_auditor { + my $self = shift; + + my $run = $self->build_run(); + my $settings = $self->settings; + + my $ipc = $self->ipc; + $ipc->spawn( + stdin => $self->auditor_reader(), + stdout => $self->auditor_writer(), + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + auditor => 'Test2::Harness::Auditor', + $run->run_id, + procname_prefix => $settings->debug->procname_prefix, + ], + ); + + close($self->auditor_writer()); +} + +sub collector_options { () } + +sub start_collector { + my $self = shift; + + my $dir = $self->workdir; + my $run = $self->build_run(); + my $settings = $self->settings; + my $runner_pid = $self->runner_pid; + + my ($rh, $wh); + pipe($rh, $wh) or die "Could not create pipe"; + + my %options = (show_runner_output => 1); + if ($settings->check_prefix('display')) { + $options{show_runner_output} = $settings->display->hide_runner_output ? 0 : 1; + $options{truncate_runner_output} = $settings->display->truncate_runner_output; + } + + %options = ( + %options, + $self->collector_options(), + ); + + my $ipc = $self->ipc; + $ipc->spawn( + stdout => $self->collector_writer, + stdin => $rh, + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + collector => 'Test2::Harness::Collector', + $dir, $run->run_id, $runner_pid, + %options, + ], + ); + + close($rh); + print $wh encode_json($run) . "\n"; + close($wh); + + close($self->collector_writer()); +} + +sub start_runner { + my $self = shift; + my %args = @_; + + $args{monitor_preloads} //= $self->monitor_preloads; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $ipc = $self->ipc; + my $proc = $ipc->spawn( + stderr => File::Spec->catfile($dir, 'error.log'), + stdout => File::Spec->catfile($dir, 'output.log'), + env_vars => { @prof ? (NYTPROF => 'start=no:addpid=1') : () }, + no_set_pgrp => 1, + command => [ + $^X, @prof, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + %args, + ], + ); + + $self->{+RUNNER_PID} = $proc->pid; + + return $proc; +} + +sub parse_args { + my $self = shift; + my $settings = $self->settings; + my $args = $self->args; + + my $dest = $settings->finder->search; + for my $arg (@$args) { + next if $arg eq '--'; + if ($arg eq '::') { + $dest = $settings->run->test_args; + next; + } + + push @$dest => $arg; + } + + return; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/projects.pm b/liby/App/Yath/Command/projects.pm new file mode 100644 index 000000000..4f3d866cd --- /dev/null +++ b/liby/App/Yath/Command/projects.pm @@ -0,0 +1,26 @@ +package App::Yath::Command::projects; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'App::Yath::Command::test'; +use Test2::Harness::Util::HashBase; + +sub summary { "Run tests for multiple projects" } +sub cli_args { "[--] projects_dir [::] [arguments to test scripts]" } + +sub description { + return <<" EOT"; +This command will run all the tests for each project within a parent directory. + EOT +} + +sub finder_args {(multi_project => 1)} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/ps.pm b/liby/App/Yath/Command/ps.pm new file mode 100644 index 000000000..b29c63691 --- /dev/null +++ b/liby/App/Yath/Command/ps.pm @@ -0,0 +1,76 @@ +package App::Yath::Command::ps; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::status'; +use Test2::Harness::Util::HashBase qw/queue/; + +sub group { 'persist' } + +sub summary { "Process list for the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +List all running processes and runner stages. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + my @jobs; + + my $stage_status = $state->stage_readiness // {}; + for my $stage (keys %$stage_status) { + my $pid = $stage_status->{$stage} // next; + $pid = 'N/A' if $pid == 1; + push @jobs => [$pid, "Runner Stage", $stage]; + } + + my $running = $state->running_tasks; + for my $task (values %$running) { + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // 'N/A'; + my $file = $task->{rel_file}; + push @jobs => [$pid, "Running Test", $file]; + } + + my $process_table = Term::Table->new( + collapse => 1, + header => [qw/pid type name/], + rows => [sort { $a->[0] <=> $b->[0] } @jobs], + ); + + print "\n**** Running Processes ****\n"; + print "$_\n" for $process_table->render; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/reload.pm b/liby/App/Yath/Command/reload.pm new file mode 100644 index 000000000..6ccb283af --- /dev/null +++ b/liby/App/Yath/Command/reload.pm @@ -0,0 +1,52 @@ +package App::Yath::Command::reload; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); +use Test2::Harness::Util::File::JSON; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Reload the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This will send a SIGHUP to the persistent runner, forcing it to reload. This +will also clear the blacklist allowing all preloads to load as normal. + EOT +} + +sub run { + my $self = shift; + + my $pfile = find_pfile($self->settings, no_fatal => 1) + or die "Could not find a persistent yath running.\n"; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + + my $blacklist = File::Spec->catfile($data->{dir}, 'BLACKLIST'); + if (-e $blacklist) { + print "Deleting module blacklist...\n"; + unlink($blacklist) or warn "Could not delete blacklist file!"; + } + + print "\nSending SIGHUP to $data->{pid}\n\n"; + kill('HUP', $data->{pid}) or die "Could not send signal!\n"; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/replay.pm b/liby/App/Yath/Command/replay.pm new file mode 100644 index 000000000..375c4ddf7 --- /dev/null +++ b/liby/App/Yath/Command/replay.pm @@ -0,0 +1,109 @@ +package App::Yath::Command::replay; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; +require App::Yath::Command::test; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/+renderers <final_data <log_file <tests_seen <asserts_seen/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::PreCommand', +); + + +sub group { 'log' } + +sub summary { "Replay a test run from an event log" } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [job1, job2, ...]" } + +sub description { + return <<" EOT"; +This yath command will re-run the harness against an event log produced by a +previous test run. The only required argument is the path to the log file, +which maybe compressed. Any extra arguments are assumed to be job id's. If you +list any jobs, only listed jobs will be processed. + +This command accepts all the same renderer/formatter options that the 'test' +command accepts. + EOT +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; +} + +sub run { + my $self = shift; + + my $args = $self->args; + my $settings = $self->settings; + my $renderers = $self->App::Yath::Command::test::renderers; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my $jobs = @$args ? {map {$_ => 1} @$args} : undef; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $e (@events) { + last unless defined $e; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + if ($jobs) { + my $f = $e->{facet_data}->{harness_job_start} // $e->{facet_data}->{harness_job_queued}; + if ($f && !$jobs->{$e->{job_id}}) { + for my $field (qw/rel_file abs_file file/) { + my $file = $f->{$field} or next; + next unless $jobs->{$file}; + $jobs->{$e->{job_id}} = 1; + last; + } + } + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + else { + next if $jobs && !$jobs->{$e->{job_id}}; + $_->render_event($e) for @$renderers; + } + } + } + + $_->finish() for @$renderers; + + my $final_data = $self->{+FINAL_DATA} or die "Log did not contain final data!\n"; + + $self->App::Yath::Command::test::render_final_data($final_data); + $self->App::Yath::Command::test::render_summary($final_data->{pass}); + + return $final_data->{pass} ? 0 : 1; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/resources.pm b/liby/App/Yath/Command/resources.pm new file mode 100644 index 000000000..c83698e69 --- /dev/null +++ b/liby/App/Yath/Command/resources.pm @@ -0,0 +1,160 @@ +package App::Yath::Command::resources; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); +use Time::HiRes qw/sleep/; + +use App::Yath::Util qw/find_pfile/; + +use App::Yath::Options; +use Test2::Harness::State; +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/+state/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Runner', +); + +sub group { 'state' } + +sub summary { "View the state info for a test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +A look at the state and resources used by a runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub newest { + my ($a, $b) = @_; + return $a unless $b; + return $b unless $a; + + my @as = stat($a); + my @bs = stat($b); + return $a if $as[9] > $bs[9]; + return $b; +} + +sub state { + my $self = shift; + + return $self->{+STATE} if $self->{+STATE}; + + my $info_file; + opendir(my $dh, "./") or die "Could not open current dir: $!"; + for my $file (readdir($dh)) { + next unless $file =~ m{^\.test_info\.\S+\.json$}; + $info_file = newest($info_file, "./$file"); + } + + my $pfile = find_pfile($self->settings, no_fatal => 1); + + if (my $use = newest($info_file, $pfile)) { + if ($info_file) { + my $data = Test2::Harness::Util::File::JSON->new(name => $info_file)->read; + return $self->{+STATE} = Test2::Harness::Runner::State->new(%$data, observe => 1); + } + + if (my $pfile = find_pfile($self->settings, no_fatal => 1)) { + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + my $workdir = $data->{dir}; + my $all_state = Test2::Harness::State->new(workdir => $workdir); + + return $self->{+STATE} = Test2::Harness::Runner::State->new( + all_state => $all_state, + observe => 1, + job_count => $all_state->job_count // 1, + workdir => $data->{dir}, + ); + } + } + + return; +} + +sub shared { + my $self = shift; + + my $shared; + eval { + require Test2::Harness::Runner::Resource::SharedJobSlots; + $shared = Test2::Harness::Runner::Resource::SharedJobSlots->new( + settings => $self->settings, + ); + 1; + }; + + return $shared; +} + +sub run { + my $self = shift; + + my $res; + + if(my $state = $self->state) { + my @list; + $res = sub { + unless (@list) { + $state->poll; + @list = (@{$state->resources}, undef); + } + + return shift @list; + }; + } + elsif (my $shared = $self->shared) { + my $alt = 0; + $res = sub { + if ($alt) { + $alt = 0; + return undef; + } + + $alt = 1; + return $shared; + }; + } + + die "No persistent runner, no running test, and no shared resources found\n" + unless $res; + + while (1) { + my @out = ( + "\r\e[2J\r\e[1;1H", + "\n==== Resource state ====\n", + ); + while (my $resource = $res->()) { + my @lines = $resource->status_lines; + next unless @lines; + push @out => ( + "\nResource: " . ref($resource) . "\n", + join "\n" => @lines, + ); + } + push @out => "\n\n"; + print @out; + sleep 0.1; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/run.pm b/liby/App/Yath/Command/run.pm new file mode 100644 index 000000000..f5a6b49f2 --- /dev/null +++ b/liby/App/Yath/Command/run.pm @@ -0,0 +1,242 @@ +package App::Yath::Command::run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; +use Test2::Harness::Util qw/mod2file open_file/; +use Test2::Util::Table qw/table/; + +use File::Spec; + +use Carp qw/croak/; + +use parent 'App::Yath::Command::test'; +use Test2::Harness::Util::HashBase qw/+pfile_data +pfile/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Finder', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Run', +); + +option_group {prefix => 'run'} => sub { + option check_reload_state => ( + type => 'b', + description => 'Abort the run if there are unfixes reload errors and show a confirmation dialogue for unfixed reload warnings.', + default => 1, + ); +}; + + +sub group { 'persist' } + +sub summary { "Run tests using the persistent test runner" } +sub cli_args { '[--] [test files/dirs] [::] [arguments to test scripts] [test_file.t] [test_file2.t="--arg1 --arg2 --param=\'foo bar\'"] [:: --argv-for-all-tests]' } + +sub description { + return <<" EOT"; +This command will run tests through an already started persistent instance. See +the start command for details on how to launch a persistant instance. + EOT +} + +sub write_settings_to {} +sub setup_plugins {} +sub setup_resources {} +sub teardown_plugins {} +sub finalize_plugins {} +sub pfile_params { () } + + +sub monitor_preloads { 1 } +sub job_count { 1 } + +sub collector_options { (persistent_runner => 1) } + +sub terminate_queue { + my $self = shift; + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + return unless exists $queue->{$self->{+RUN_ID}}; + $queue->{$self->{+RUN_ID}}->{closed} = 1; + }); +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + + if ($settings->run->check_reload_state) { + return 255 unless $self->check_reload_state; + } + + return $self->SUPER::run(@_); +} + +sub write_test_info { + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; +} + +sub check_reload_state { + my $self = shift; + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + my $reload_status = $state->reload_state // {}; + + my (@out, $errors, $warnings, %seen); + for my $stage (sort keys %$reload_status) { + for my $file (keys %{$reload_status->{$stage}}) { + next if $seen{$file}++; + my $data = $reload_status->{$stage}->{$file} or next; + + push @out => "\n==== SOURCE FILE: $file ====\n"; + if ($data->{error}) { + $errors++; + push @out => $data->{error}; + } + + for (@{$data->{warnings} // []}) { + push @out => $_; + $warnings++; + } + } + } + $errors //= 0; + $warnings //= 0; + + return 1 unless @out || $errors || $warnings; + + print <<" EOT", @out; +******************************************************************************* +* Some source files were reloaded with errors or warnings +* Errors: $errors +* Warnings: $warnings +******************************************************************************* + + EOT + + if ($errors) { + print <<" EOT"; + +******************************************************************************* +Aborting due to reload errors. Please fix the errors so that the modules reload +cleanly, then try the run again. In most cases you will not need to reload the +runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + + EOT + + return 0; + } + elsif ($warnings) { + print <<" EOT"; + +******************************************************************************* +Warnings were encountered when reloading source files, please see the output +above. If these warnings are a problem you should abort this run (control+c) +and correct them before trying again. In most cases you will not need to reload +the runner, simply fix the problem with the source file(s) and the runner will +reload them automatically. + +If these warnings are not indicitive of a problem you may continue by pressing +enter/return. + + EOT + + if (-t STDIN) { + my $ignore = <STDIN>; + return 1; + } + else { + print STDERR "No TTY detected, aborting run due to warnings...\n"; + return 0; + } + } + + return 0; +} + +sub init { + my $self = shift; + + my $settings = $self->settings; + my $pdata = $self->pfile_data; + + my $all_state = Test2::Harness::State->new(workdir => $pdata->{dir}); + my $runner_settings = $all_state->data->settings; + + for my $prefix (sort keys %{$runner_settings}) { + next if $settings->check_prefix($prefix); + + my $new = $settings->define_prefix($prefix); + ${$new->vivify_field('from_runner')} = 1; + for my $key (sort keys %{$runner_settings->{$prefix}}) { + ${$new->vivify_field($key)} = $runner_settings->{$prefix}->{$key}; + } + } + + return $self->SUPER::init(@_); +} + +sub pfile { + my $self = shift; + $self->{+PFILE} //= find_pfile($self->settings, $self->pfile_params) or die "No persistent harness was found for the current path.\n"; +} + +sub pfile_data { + my $self = shift; + return $self->{+PFILE_DATA} if $self->{+PFILE_DATA}; + + my $pfile = $self->pfile; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + $data->{pfile_path} //= $pfile; + + print "\nFound: $data->{pfile_path}\n"; + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + + return $self->{+PFILE_DATA} = $data; +} + +sub workdir { + my $self = shift; + return $self->pfile_data->{dir}; +} + +sub start_runner { + my $self = shift; + + my $data = $self->pfile_data; + + $self->{+RUNNER_PID} = $data->{pid}; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/runner.pm b/liby/App/Yath/Command/runner.pm new file mode 100644 index 000000000..a7acdb816 --- /dev/null +++ b/liby/App/Yath/Command/runner.pm @@ -0,0 +1,519 @@ +package App::Yath::Command::runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Config qw/%Config/; +use File::Spec; + +# For some reason Filter::Util::Class breaks the STDIN filehandle. This works +# around that. +my $FIX_STDIN; +BEGIN { + require goto::file; + no strict 'refs'; + no warnings 'redefine'; + + my $int_done; + my $orig = goto::file->can('filter'); + *goto::file::filter = sub { + local $.; + my $out = $orig->(@_); + seek(STDIN, 0, 0) if $FIX_STDIN; + + unless ($int_done++) { + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + my $ok; + for (1 .. 10) { + $ok = open(STDIN, '<', $fifo); + last if $ok; + die "Could not open fifo ($fifo): $!"; + sleep 1; + } + + die "Could not open fifo ($fifo): $!" unless $ok; + + print STDERR <<' EOT'; + +******************************************************************************* +* YATH IS RUNNING IN INTERACTIVE MODE * +* * +* STDIN is comming from a fifo pipe, not a TTY! * +* * +* The $ENV{YATH_INTERACTIVE} var is set to the FIFO being used. * +* * +* VERBOSE mode has been turned on for you * +* * +* Only 1 test will run at a time * +* * +* The main yath process no longer has STDIN, so yath plugins that wait for * +* input WILL BREAK. * +* * +* Prompts that do not end with a newline may have a 1 second delay before * +* they are displayed, they will be prefixed with [INTERACTIVE] * +* * +* Any stdin/stdout that is printed in 2 parts without a newline and more than * +* a 1 second delay will be printed with the [INTERACTIVE] prefix, if they are * +* not actually a prompt you can safely ignore them. * +* * +* It is possible that a prompt was displayed before this message, please * +* check above if your prompt appears missing. This is an IO fluke, not a bug. * +* * +******************************************************************************* + + EOT + } + } + + return $out; + }; +} + +use Test2::Harness::IPC(); +use Test2::Harness::State; + +use Carp qw/confess/; +use Scalar::Util qw/openhandle/; +use List::Util qw/first/; +use File::Path qw/remove_tree/; + +use Scope::Guard; + +use Test2::Util qw/clone_io/; + +use Long::Jump qw/setjump longjump/; + +use Test2::Harness::Util qw/mod2file write_file_atomic open_file clean_path process_includes/; + +use Test2::Harness::Util::IPC qw/swap_io/; + +use Test2::Harness::Runner::Preloader(); + +my @SIGNALS = grep { $_ ne 'ZERO' } split /\s+/, $Config{sig_name}; + +# If FindBin is installed, go ahead and load it. We do not care much about +# success vs failure here. +BEGIN { + local $@; + eval { require FindBin; FindBin->import }; +} + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub internal_only { 1 } +sub summary { "For internal use only" } +sub name { 'runner' } + +sub init { confess(ref($_[0]) . " is not intended to be instantiated") } +sub run { confess(ref($_[0]) . " does not implement run()") } + +our $RUNNER_PID; +sub generate_run_sub { + my $class = shift; + my ($symbol, $argv, $spawn_settings) = @_; + my ($dir, %args) = @$argv; + + $RUNNER_PID = $$; + my $runner_pid = $$; + my $all_state = Test2::Harness::State->new(workdir => $dir); + my $settings = $all_state->settings; + + my $name = $ENV{NESTED_YATH} ? 'yath-nested-runner' : 'yath-runner'; + $name = $settings->debug->procname_prefix . "-${name}" if $settings->debug->procname_prefix; + $0 = $name; + + my $cleanup = $class->cleanup($settings, \%args, $dir); + + my $jump = setjump "Test-Runner" => sub { + local $.; + + my %orig_sig = %SIG; + my $guard = Scope::Guard->new(sub { + my %seen; + for my $sig (@SIGNALS) { + next if $seen{$sig}++; + if (exists $orig_sig{$sig}) { + $SIG{$sig} = $orig_sig{$sig}; + } + else { + delete $SIG{$sig}; + } + } + }); + + my $runner = $settings->build( + runner => 'Test2::Harness::Runner', + + %args, + + dir => $dir, + settings => $settings, + all_state => $all_state, + + fork_job_callback => sub { $class->launch_via_fork(@_) }, + fork_spawn_callback => sub { $class->launch_spawn(@_) }, + respawn_runner_callback => sub { return unless $$ == $runner_pid; longjump "Test-Runner" => 'respawn' }, + ); + + my $exit = $runner->process(); + + if ($$ == $runner_pid) { + $_->cleanup() for @{$runner->state->resources}; + } + + my $complete = File::Spec->catfile($dir, 'complete'); + write_file_atomic($complete, '1'); + + exit($exit // 1); + }; + + die "Test runner completed, but failed to exit" unless $jump; + + my ($action, $job, $stage) = @$jump; + + if($action eq 'respawn') { + print "$$ Respawning the runner...\n"; + $cleanup->dismiss(1); + exec($^X, $settings->harness->script, @{$spawn_settings->harness->orig_argv}); + warn "exec failed!"; + exit 1; + } + + die "Invalid action: $action" if $action ne 'run_test'; + + if (my $chdir = $job->ch_dir) { + chdir($chdir) or die "Could not chdir: $!"; + } + goto::file->import($job->run_file); + $class->cleanup_process($job, $stage); + DB::enable_profile() if $settings->runner->nytprof; +} + +sub cleanup { + my $class = shift; + my ($settings, $args, $dir) = @_; + + my $pfile = $args->{persist} or return; + + my $pid = $$; + return Scope::Guard->new(sub { + return unless $pid == $$; + + unlink($pfile); + + remove_tree($dir, {safe => 1, keep_root => 0}) unless $settings->debug->keep_dirs; + }); +} + +sub get_stage { + my $class = shift; + my ($runner) = @_; + + return unless $runner->can('stage'); + + my $stage_name = $runner->stage or return; + my $preloader = $runner->preloader or return; + my $p = $preloader->staged or return; + + return $p->stage_lookup->{$stage_name}; +} + +sub launch_spawn { + my $class = shift; + my ($runner, $spawn) = @_; + + my $pid = fork() // die $!; + if ($pid) { + waitpid($pid, 0); + return; + } + + require POSIX; + POSIX::setsid or die "setsid: $!"; + + $pid = fork // die $!; + exit 0 if $pid; + + eval { + my ($wh); + pipe(STDIN, $wh) or die "Could not create pipe: $!"; + $pid = $class->launch_via_fork($runner, $spawn); + + if ($pid) { + open(my $fh, '>>', $spawn->{task}->{ipcfile}) or die "Could not open pidfile: $!"; + print $fh "$$\n$pid\n" . fileno($wh) . "\n"; + $fh->flush(); + waitpid($pid, 0); + print $fh "$?\n"; + close($fh); + } + + exit(0); + }; + warn "Unknown problem daemonizing: $@"; + exit(1); +} + +sub launch_via_fork { + my $class = shift; + my ($runner, $job) = @_; + + my $stage = $class->get_stage($runner); + + $stage->do_pre_fork($job) if $stage; + + my $pid = fork(); + die "Failed to fork: $!" unless defined $pid; + + # In parent + return $pid if $pid; + + # In Child + my $ok = eval { + $0 = 'yath-pending-test'; + setpgrp(0, 0) if Test2::Harness::IPC::USE_P_GROUPS(); + $runner->stop(); + + $stage->do_post_fork($job) if $stage; + + longjump "Test-Runner" => ('run_test', $job, $stage); + + 1; + }; + my $err = $@; + eval { warn $err } unless $ok; + exit(1); +} + +sub cleanup_process { + my $class = shift; + my ($job, $stage) = @_; + + $class->update_io($job); # Get the correct filehandles in place early + $class->set_env($job); # Set up the necessary env vars + $class->build_init_state($job); # Lots of 'misc' stuff. + $class->do_loads($job); # Modules that we wanted loaded/imported post fork + $class->test2_state($job); # Normalize the Test2 state + + $stage->do_pre_launch($job) if $stage; + + $class->final_state($job); # Important final cleanup +} + +sub test2_state { + my $class = shift; + my ($job) = @_; + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stop_preload(); + Test2::API::test2_post_preload_reset(); + } + + if ($job->use_stream) { + $ENV{T2_FORMATTER} = 'Stream'; + require Test2::Formatter::Stream; + Test2::Formatter::Stream->import(dir => $job->event_dir, job_id => $job->job_id); + } + + if ($job->event_uuids) { + require Test2::Plugin::UUID; + Test2::Plugin::UUID->import(); + } + + if ($job->mem_usage) { + require Test2::Plugin::MemUsage; + Test2::Plugin::MemUsage->import(); + } + + if ($job->io_events) { + require Test2::Plugin::IOEvents; + Test2::Plugin::IOEvents->import(); + } + + return; +} + +sub final_state { + my $class = shift; + my ($job) = @_; + + @ARGV = $job->args; + + # toggle -w switch late + $^W = 1 if $job->use_w_switch; + + # reset the state of empty pattern matches, so that they have the same + # behavior as running in a clean process. + # see "The empty pattern //" in perlop. + # note that this has to be dynamically scoped and can't go to other subs + "" =~ /^/; + + return; +} + +sub do_loads { + my $class = shift; + my ($job) = @_; + + local $@; + my $importer = eval <<' EOT' or die $@; +package main; +#line 0 "-" +sub { $_[0]->import(@{$_[1]}) } + EOT + + for my $set ($job->load_import) { + my ($mod, $args) = @$set; + my $file = mod2file($mod); + local $0 = '-'; + require $file; + $importer->($mod, $args); + } + + for my $mod ($job->load) { + my $file = mod2file($mod); + local $0 = '-'; + require $file; + } + + return; +} + +sub build_init_state { + my $class = shift; + my ($job) = @_; + + $0 = $job->rel_file; + $class->_reset_DATA(); + @ARGV = (); + + srand(); # avoid child processes sharing the same seed value as the parent + + @INC = process_includes( + list => [$job->includes], + include_dot => $job->unsafe_inc, + include_current => 1, + clean => 1, + ); + + # if FindBin is preloaded, reset it with the new $0 + FindBin::init() if defined &FindBin::init; + + # restore defaults + Getopt::Long::ConfigDefaults() if defined &Getopt::Long::ConfigDefaults; + + return; +} + +sub set_env { + my $class = shift; + my ($job) = @_; + + my $env = $job->env_vars; + { + no warnings 'uninitialized'; + $ENV{$_} = $env->{$_} for keys %$env; + } + + $ENV{T2_HARNESS_FORKED} = 1; + $ENV{T2_HARNESS_PRELOAD} = 1; + + return; +} + +sub update_io { + my $class = shift; + my ($job) = @_; + + my $out_fh = open_file($job->out_file, '>'); + my $err_fh = open_file($job->err_file, '>'); + + my $in_file = $job->in_file; + my $in_fh = open_file($in_file, '<') if $in_file; + + $out_fh->autoflush(1); + $err_fh->autoflush(1); + + # Keep a copy of the old STDERR for a while so we can still report errors + my $stderr = clone_io(\*STDERR); + + my $die = sub { + my @caller = caller; + my @caller2 = caller(1); + my $msg = "$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2]).\n"; + print $stderr $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $in_fh, $die, '<&') if $in_file; + swap_io(\*STDOUT, $out_fh, $die, '>&'); + swap_io(\*STDERR, $err_fh, $die, '>&'); + + $FIX_STDIN = 1 if $in_file; + + return; +} + +# Heavily modified from forkprove +sub _reset_DATA { + my $class = shift; + + for my $set (@{$class->preload_list}) { + my ($mod, $file, $pos) = @$set; + + my $fh = do { + no strict 'refs'; + *{$mod . '::DATA'}; + }; + + # note that we need to ensure that each forked copy is using a + # different file handle, or else concurrent processes will interfere + # with each other + + close $fh if openhandle($fh); + + if (open $fh, '<', $file) { + seek($fh, $pos, 0); + } + else { + warn "Couldn't reopen DATA for $mod ($file): $!"; + } + } +} + +# Heavily modified from forkprove +sub preload_list { + my $class = shift; + + my $list = []; + + for my $loaded (keys %INC) { + next unless $loaded =~ /\.pm$/; + + my $mod = $loaded; + $mod =~ s{/}{::}g; + $mod =~ s{\.pm$}{}; + + my $fh = do { + no strict 'refs'; + no warnings 'once'; + *{$mod . '::DATA'}; + }; + + next unless openhandle($fh); + push @$list => [$mod, $INC{$loaded}, tell($fh)]; + } + + return $list; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/spawn.pm b/liby/App/Yath/Command/spawn.pm new file mode 100644 index 000000000..0a651a373 --- /dev/null +++ b/liby/App/Yath/Command/spawn.pm @@ -0,0 +1,205 @@ +package App::Yath::Command::spawn; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Time::HiRes qw/sleep time/; +use File::Temp qw/tempfile/; + +use Test2::Harness::Util qw/parse_exit/; + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Launch a perl script from the preloaded environment" } +sub cli_args { "[--] path/to/script.pl [options and args]" } + +sub description { + return <<" EOT"; +This will launch the specified script from the preloaded yath process. + +NOTE: environment variables are not automatically passed to the spawned +process. You must use -e or -E (see help) to specify what environment variables +you care about. + EOT +} + +option_group {prefix => 'spawn', category => 'spawn options'} => sub { + option stage => ( + short => 's', + type => 's', + description => 'Specify the stage to be used for launching the script', + long_examples => [ ' foo'], + short_examples => [ ' foo'], + default => 'default', + ); + + option copy_env => ( + short => 'e', + type => 'm', + description => "Specify environment variables to pass along with their current values, can also use a regex", + long_examples => [ ' HOME', ' SHELL', ' /PERL_.*/i' ], + short_examples => [ ' HOME', ' SHELL', ' /PERL_.*/i' ], + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables for the spawn', + ); +}; + +sub read_line { + my ($fh, $timeout) = @_; + + $timeout //= 300; + + my $start = time; + while (1) { + if ($timeout < (time - $start)) { + my @caller = caller; + die "Timed out at $caller[1] line $caller[2].\n"; + } + seek($fh, 0,1) if eof($fh); + my $out = <$fh> // next; + chomp($out); + return $out; + } +} + +# This is here for subclasses +sub queue_spawn { + my $self = shift; + my ($args) = @_; + + $self->state->queue_spawn($args); +} + +sub run_script { shift @ARGV // die "No script specified" } + +sub stage { $_[0]->settings->spawn->stage } + +sub env_vars { + my $self = shift; + + my $settings = $self->settings; + + my $env = {}; + + for my $var (@{$settings->spawn->copy_env}) { + if ($var =~ m{^/(.*)/(\w*)$}s) { + my ($re, $opts) = ($1, $2); + my $pattern = length($opts) ? "(?$opts)$re" : $re; + $env->{$_} = $ENV{$_} for grep { m/$pattern/ } keys %ENV; + } + else { + $env->{$var} = $ENV{$var}; + } + } + + my $set = $settings->spawn->env_vars; + $env->{$_} = $set->{$_} for keys %$set; + + return $env; +} + +sub set_pname { + my $self = shift; + my ($run) = @_; + + $0 = "yath-" . $self->name . " $run " . join (' ', @ARGV); +} + +sub pre_process_argv { + shift @ARGV if @ARGV && $ARGV[0] eq '--'; +} + +sub sig_handlers { qw/INT TERM HUP QUIT USR1 USR2 STOP WINCH/ } + +sub set_sig_handlers { + my $self = shift; + my ($wpid) = @_; + + local $@; + eval { my $s = $_; $SIG{$s} = sub { kill($s, $wpid) } } for $self->sig_handlers; +} + +sub clear_sig_handlers { + my $self = shift; + + local $@; + eval { my $s = $_; $SIG{$s} = 'DEFAULT' } for $self->sig_handlers; +} + +sub pre_exit_hook {} + +sub run { + my $self = shift; + + $self->pre_process_argv; + + my $run = $self->run_script; + $self->set_pname($run); + + my ($fh, $name) = tempfile(UNLINK => 1); + close($fh); + + $self->queue_spawn({ + stage => $self->stage // 'default', + file => $run, + owner => $$, + ipcfile => $name, + args => [@ARGV], + env_vars => $self->env_vars, + }); + + open($fh, '<', $name) or die "Could not open ipcfile: $!"; + my $mpid = read_line($fh); + my $wpid = read_line($fh); + my $win = read_line($fh); + + $self->set_sig_handlers($wpid); + + open(my $wfh, '>>', "/proc/$mpid/fd/$win") or die "Could not open /proc/$wpid/fd/$win: $!"; + $wfh->autoflush(1); + STDIN->blocking(0); + while (0 < kill(0, $mpid)) { + my $line = <STDIN>; + if (defined $line) { + print $wfh $line; + } + else { + sleep 0.2; + } + } + + $self->clear_sig_handlers(); + + my $exit = read_line($fh) // die "Could not get exit code"; + $exit = parse_exit($exit); + if ($exit->{sig}) { + print STDERR "Terminated with signal: $exit->{sig}.\n"; + kill($exit->{sig}, $$); + } + + print STDERR "Exited with code: $exit->{err}.\n" if $exit->{err}; + + $self->pre_exit_hook($exit); + + exit($exit->{err}); +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/speedtag.pm b/liby/App/Yath/Command/speedtag.pm new file mode 100644 index 000000000..661ee8753 --- /dev/null +++ b/liby/App/Yath/Command/speedtag.pm @@ -0,0 +1,189 @@ +package App::Yath::Command::speedtag; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::File::JSONL; + +use App::Yath::Options; + +use Cwd qw/getcwd/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/-log_file -max_short -max_medium/; +use Test2::Harness::Util qw/clean_path/; + +include_options( + 'App::Yath::Options::Debug', +); + +option_group {prefix => 'speedtag', category => 'speedtag options'} => sub { + option generate_durations_file => ( + type => 'd', + alt => ['durations', 'duration'], + description => "Write out a duration json file, if no path is provided 'duration.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/durations.json'], + + normalize => \&normalize_duration, + action => \&duration_action, + ); + + option pretty => ( + description => "Generate a pretty 'durations.json' file when combined with --generate-durations-file. (sorted and multilines)", + default => 0, + ); +}; + +sub group { 'log' } + +sub summary { "Tag tests with duration (short medium long) using a source log" } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] max_short_duration_seconds max_medium_duration_seconds" } + +sub description { + return <<" EOT"; +This command will read the test durations from a log and tag/retag all tests +from the log based on the max durations for each type. + EOT +} + +sub init { + my $self = shift; + + $self->{+MAX_SHORT} //= 15; + $self->{+MAX_MEDIUM} //= 30; +} + +sub normalize_duration { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub duration_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('durations.json'); +} + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + my $initial_dir = clean_path(getcwd()); + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + $self->{+MAX_SHORT} = shift @$args if @$args; + $self->{+MAX_MEDIUM} = shift @$args if @$args; + + die "max short duration must be an integer, got '$self->{+MAX_SHORT}'" unless $self->{+MAX_SHORT} && $self->{+MAX_SHORT} =~ m/^\d+$/; + die "max short duration must be an integer, got '$self->{+MAX_MEDIUM}'" unless $self->{+MAX_MEDIUM} && $self->{+MAX_MEDIUM} =~ m/^\d+$/; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my $durations_file = $self->settings->speedtag->generate_durations_file; + my %durations; + + while(1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + next unless $f->{harness_job_end}; + + my $job = {}; + $job->{file} = clean_path( $f->{harness_job_end}->{file} ) if $f->{harness_job_end} && $f->{harness_job_end}->{file}; + $job->{time} = $f->{harness_job_end}->{times}->{totals}->{total} if $f->{harness_job_end} && $f->{harness_job_end}->{times}; + + next unless $job->{file} && $job->{time}; + + my $dur; + if ($job->{time} < $self->{+MAX_SHORT}) { + $dur = 'short'; + } + elsif ($job->{time} < $self->{+MAX_MEDIUM}) { + $dur = 'medium'; + } + else { + $dur = 'long'; + } + + my $fh; + unless (open($fh, '<', $job->{file})) { + warn "Could not open file $job->{file} for reading\n"; + next; + } + + my @lines; + my $injected; + for my $line (<$fh>) { + if ($line =~ m/^(\s*)#(\s*)HARNESS-(CAT(EGORY)?|DUR(ATION))-(LONG|MEDIUM|SHORT)$/i) { + next if $injected++; + $line = "${1}#${2}HARNESS-DURATION-" . uc($dur) . "\n"; + } + push @lines => $line; + } + unless ($injected) { + my $new_line = "# HARNESS-DURATION-" . uc($dur) . "\n"; + my @header; + while (@lines && $lines[0] =~ m/^(#|use\s|package\s)/) { + push @header => shift @lines; + } + + unshift @lines => (@header, $new_line); + } + + close($fh); + unless (open($fh, '>', $job->{file})) { + warn "Could not open file $job->{file} for writing\n"; + next; + } + + print $fh @lines; + close($fh); + + if ( $durations_file ) { + my $tfile = $job->{file}; + $tfile =~ s{^\Q$initial_dir\E/+}{}; + $durations{ $tfile } = uc( $dur ); + } + + print "Tagged '$dur': $job->{file}\n"; + } + } + + if ( $durations_file ) { + my $jfile = Test2::Harness::Util::File::JSON->new(name => $durations_file, pretty => $self->settings->speedtag->pretty ); + $jfile->write( \%durations ); + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/start.pm b/liby/App/Yath/Command/start.pm new file mode 100644 index 000000000..b74c4bb95 --- /dev/null +++ b/liby/App/Yath/Command/start.pm @@ -0,0 +1,207 @@ +package App::Yath::Command::start; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util qw/mod2file open_file parse_exit clean_path/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use POSIX; +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Time::HiRes qw/sleep/; + +use Carp qw/croak/; +use File::Path qw/remove_tree/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Workspace', + 'App::Yath::Options::Persist', + 'App::Yath::Options::Collector', +); + +option_group {prefix => 'runner', category => "Persistent Runner Options"} => sub { + option reload => ( + short => 'r', + type => 'b', + description => "Attempt to reload modified modules in-place, restarting entire stages only when necessary.", + default => 0, + ); + + option restrict_reload => ( + type => 'D', + long_examples => ['', '=path'], + short_examples => ['', '=path'], + description => "Only reload modules under the specified path, if no path is specified look at anything under the .yath.rc path, or the current working directory.", + + normalize => sub { $_[0] eq '1' ? $_[0] : clean_path($_[0]) }, + action => \&restrict_action, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); +}; + +sub restrict_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + if ($norm eq '1') { + my $hset = $settings->harness; + my $path = $hset->config_file || $hset->cwd; + $path //= do { require Cwd; Cwd::getcwd() }; + $path =~ s{\.yath\.rc$}{}g; + push @{$$slot} => $path; + } + else { + push @{$$slot} => $norm; + } +} + +sub MAX_ATTACH() { 1_048_576 } + +sub group { 'persist' } + +sub always_keep_dir { 1 } + +sub summary { "Start the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command is used to start a persistant instance of yath. A persistant +instance is useful because it allows you to preload modules in advance, +reducing start time for any tests you decide to run as you work. + +A running instance will watch for changes to any preloaded files, and restart +itself if anything changes. Changed files are blacklisted for subsequent +reloads so that reloading is not a frequent occurence when editing the same +file over and over again. + EOT +} + +sub run { + my $self = shift; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} //= 1; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my $pfile = find_pfile($settings, vivify => 1, no_checks => 1); + + if (-f $pfile) { + remove_tree($dir, {safe => 1, keep_root => 0}); + die "Persistent harness appears to be running, found $pfile\n"; + } + + my $all_state = Test2::Harness::State->new( + workdir => $dir, + settings => $settings, + ); + $all_state->transaction(w => sub { 1 }); + + $self->setup_plugins(); + $self->setup_resources(); + + my $stderr = File::Spec->catfile($dir, 'error.log'); + my $stdout = File::Spec->catfile($dir, 'output.log'); + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $pid = run_cmd( + stderr => $stderr, + stdout => $stdout, + + no_set_pgrp => !$settings->runner->daemon, + + command => [ + $^X, @prof, $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + monitor_preloads => 1, + persist => $pfile, + jobs_todo => 0, + ], + ); + + unless ($settings->runner->quiet) { + print "\nPersistent runner started!\n"; + + print "Runner PID: $pid\n"; + print "Runner dir: $dir\n"; + print "\nUse `yath watch` to monitor the persistent runner\n\n" if $settings->runner->daemon; + } + + Test2::Harness::Util::File::JSON->new(name => $pfile)->write({ + pid => $pid, + dir => $dir, + version => $VERSION, + user => $ENV{USER}, + hostname => hostname(), + }); + + return 0 if $settings->runner->daemon; + + $SIG{TERM} = sub { kill(TERM => $pid) }; + $SIG{INT} = sub { kill(INT => $pid) }; + + my $err_fh = open_file($stderr, '<'); + my $out_fh = open_file($stdout, '<'); + + while (1) { + my $out = waitpid($pid, WNOHANG); + my $wstat = $?; + + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + sleep(0.02) unless $out || $count; + + next if $out == 0; + return 255 if $out < 0; + + my $exit = parse_exit($?); + return $exit->{err} || $exit->{sig} || 0; + } +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/status.pm b/liby/App/Yath/Command/status.pm new file mode 100644 index 000000000..2b1f0bd1b --- /dev/null +++ b/liby/App/Yath/Command/status.pm @@ -0,0 +1,148 @@ +package App::Yath::Command::status; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Term::Table(); +use File::Spec(); + +use Test2::Harness::Runner::State; +use Test2::Harness::Util::File::JSON(); + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Status info and process lists for the runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will provide health details and a process list for the runner. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + my $data = $self->pfile_data(); + + my $state = Test2::Harness::Runner::State->new( + workdir => $self->workdir, + observe => 1, + ); + + $state->poll; + + print "\n**** Pending tests: ****\n"; + my $pending = $state->pending_tasks; + for my $run ($state->run, @{$state->pending_runs // []}) { + next unless $run; + my $run_id =$run->{run_id} or next; + + print "\nRun $run_id:\n"; + my $pending = $pending->{$run_id} // {}; + my @tasks; + my @check = ($pending); + while (my $it = shift @check) { + my $ref = ref($it); + + if ($ref eq 'ARRAY') { + push @check => @$it; + next; + } + + if ($ref eq 'HASH') { + if ($it->{job_id}) { + push @tasks => $it; + next; + } + + push @check => values %$it; + next; + } + } + + if (!@tasks) { + print "--No pending tasks for this run--\n"; + next; + } + + my @rows = map {[$_->{job_id}, $_->{is_try} // $_->{job_try} // 0, $_->{rel_file}, join(', ' => @{$_->{conflicts} // []})]} @tasks; + my $run_table = Term::Table->new( + collapse => 1, + header => [qw/uuid try test conflicts/], + rows => [ sort { $a->[2] cmp $b->[2] } @rows ], + ); + + print "$_\n" for $run_table->render; + } + + print "\n**** Runner Stages: ****\n"; + my $stage_status = $state->stage_readiness // {}; + my $reload_status = $state->reload_state // {}; + my $reload_issues = 0; + + my $rows = []; + for my $stage (keys %$stage_status) { + my $pid = $stage_status->{$stage} ||= ''; + my $ready = $pid ? 'YES' : 'NO'; + $pid = 'N/A' if $pid && $pid == 1; + + my $issues = keys %{$reload_status->{$stage}}; + my $reload = $issues ? 'YES' : 'NO'; + $reload_issues += $issues; + + push @$rows => [$pid, $stage, $ready, $reload]; + } + + @$rows = sort { $a->[0] <=> $b->[0] } @$rows; + + my $stage_table = Term::Table->new( + collapse => 1, + header => [qw/pid stage ready/, 'reload issues'], + rows => $rows, + ); + print "$_\n" for $stage_table->render; + + if ($reload_issues) { + my %seen; + print "\n**** Reload issues: ****\n"; + for my $stage (sort keys %$reload_status) { + for my $file (keys %{$reload_status->{$stage}}) { + next if $seen{$file}++; + my $data = $reload_status->{$stage}->{$file} or next; + print "\n==== SOURCE FILE: $file ====\n"; + print $data->{error} if $data->{error}; + print $_ for @{$data->{warnings} // []}; + } + } + print "\n"; + } + + print "\n**** Running tests: ****\n"; + my $running = $state->running_tasks; + my $running_tasks = [values %$running]; + my @rows = map {[$self->get_job_pid($_->{run_id}, $_->{job_id}) // 'N/A', $_->{job_id}, $_->{is_try} // $_->{job_try} // 0, $_->{rel_file}, join(', ' => @{$_->{conflicts} // []})]} @$running_tasks; + if (@rows) { + my $run_table = Term::Table->new( + collapse => 1, + header => [qw/pid uuid try test conflicts/], + rows => [ sort { $a->[0] <=> $b->[0] } @rows ], + ); + print "$_\n" for $run_table->render; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/stop.pm b/liby/App/Yath/Command/stop.pm new file mode 100644 index 000000000..4cb488e5f --- /dev/null +++ b/liby/App/Yath/Command/stop.pm @@ -0,0 +1,56 @@ +package App::Yath::Command::stop; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; + +use File::Spec(); + +use Test2::Harness::Util::File::JSON(); + +use Test2::Harness::Util qw/open_file/; +use App::Yath::Util qw/find_pfile/; +use File::Path qw/remove_tree/; + +use parent 'App::Yath::Command::run'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Stop the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will stop a persistent instance, and output any log contents. + EOT +} + +sub pfile_params { (no_fatal => 1) } + +sub run { + my $self = shift; + + $self->App::Yath::Command::test::terminate_queue(); + + $_->teardown($self->settings) for @{$self->settings->harness->plugins}; + + sleep(0.02) while kill(0, $self->pfile_data->{pid}); + + my $pfile = $self->pfile; + unlink($pfile) if -f $pfile; + + remove_tree($self->workdir, {safe => 1, keep_root => 0}) if -d $self->workdir; + + print "\n\nRunner stopped\n\n" unless $self->settings->display->quiet; + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/test.pm b/liby/App/Yath/Command/test.pm new file mode 100644 index 000000000..fa88aaa29 --- /dev/null +++ b/liby/App/Yath/Command/test.pm @@ -0,0 +1,935 @@ +package App::Yath::Command::test; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +use Test2::Harness::State; +use Test2::Harness::Run; +use Test2::Harness::Event; +use Test2::Harness::Util::File::JSON; +use Test2::Harness::IPC; + +use Test2::Harness::Runner::State; + +use Test2::Harness::Util::JSON qw/encode_json decode_json JSON/; +use Test2::Harness::Util qw/mod2file open_file chmod_tmp/; +use Test2::Util::Table qw/table/; + +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + +use File::Spec; +use Fcntl(); + +use Time::HiRes qw/sleep time/; +use List::Util qw/sum max min/; +use Carp qw/croak/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/ + <runner_pid +ipc +signal + + +run <run_id + + +auditor_reader + +collector_writer + +renderer_reader + +auditor_writer + + +renderers + +logger + +last_log + + +tests_seen + +asserts_seen + + +state +all_state + + <cleanup_subs + + <final_data +/; + +include_options( + 'App::Yath::Options::Debug', + 'App::Yath::Options::Display', + 'App::Yath::Options::Finder', + 'App::Yath::Options::Logging', + 'App::Yath::Options::PreCommand', + 'App::Yath::Options::Run', + 'App::Yath::Options::Runner', + 'App::Yath::Options::Workspace', + 'App::Yath::Options::Collector', +); + +sub MAX_ATTACH() { 1_048_576 } + +sub group { ' test' } + +sub summary { "Run tests" } +sub cli_args { '[--] [test files/dirs] [::] [arguments to test scripts] [test_file.t] [test_file2.t="--arg1 --arg2 --param=\'foo bar\'"] [:: --argv-for-all-tests]' } + +sub description { + return <<" EOT"; +This yath command (which is also the default command) will run all the test +files for the current project. If no test files are specified this command will +look for the 't', and 't2' directories, as well as the 'test.pl' file. + +This command is always recursive when given directories. + +This command will add 'lib', 'blib/arch' and 'blib/lib' to the perl path for +you by default (after any -I's). You can specify -l if you just want lib, -b if +you just want the blib paths. If you specify both -l and -b both will be added +in the order you specify (order relative to any -I options will also be +preserved. If you do not specify they will be added in this order: -I's, lib, +blib/lib, blib/arch. You can also add --no-lib and --no-blib to avoid both. + +Any command line argument that is not an option will be treated as a test file +or directory of test files to be run. + +If you wish to specify the ARGV for tests you may append them after '::'. This +is mainly useful for Test::Class::Moose and similar tools. EVERY test run will +get the same ARGV. + EOT +} + +sub spawn_args { + my $self = shift; + my ($settings) = @_; + + my @out; + + if ($ENV{T2_DEVEL_COVER} && $ENV{T2_COVER_SELF}) { + push @out => '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + } + + my $plugins = $settings->harness->plugins; + if (@$plugins) { + push @out => $_->spawn_args($settings) for grep { $_->can('spawn_args') } @$plugins; + } + + return @out; +} + +sub init { + my $self = shift; + $self->SUPER::init() if $self->can('SUPER::init'); + + $self->{+TESTS_SEEN} //= 0; + $self->{+ASSERTS_SEEN} //= 0; + + $self->{+CLEANUP_SUBS} = []; +} + +sub _resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh) = @_; + + # 1mb if we can + my $size = 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub auditor_reader { + my $self = shift; + return $self->{+AUDITOR_READER} if $self->{+AUDITOR_READER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+AUDITOR_READER}; +} + +sub collector_writer { + my $self = shift; + return $self->{+COLLECTOR_WRITER} if $self->{+COLLECTOR_WRITER}; + pipe($self->{+AUDITOR_READER}, $self->{+COLLECTOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+COLLECTOR_WRITER}); + return $self->{+COLLECTOR_WRITER}; +} + +sub renderer_reader { + my $self = shift; + return $self->{+RENDERER_READER} if $self->{+RENDERER_READER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+RENDERER_READER}; +} + +sub auditor_writer { + my $self = shift; + return $self->{+AUDITOR_WRITER} if $self->{+AUDITOR_WRITER}; + pipe($self->{+RENDERER_READER}, $self->{+AUDITOR_WRITER}) or die "Could not create pipe: $!"; + _resize_pipe($self->{+AUDITOR_WRITER}); + return $self->{+AUDITOR_WRITER}; +} + +sub workdir { + my $self = shift; + $self->settings->workspace->workdir; +} + +sub ipc { + my $self = shift; + return $self->{+IPC} //= Test2::Harness::IPC->new( + handlers => { + INT => sub { $self->handle_sig(@_) }, + TERM => sub { $self->handle_sig(@_) }, + } + ); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + eval { $_->signal($sig) } for grep { $_->can('signal') } @{$self->renderers}; + + print STDERR "\nCaught SIG$sig, forwarding signal to child processes...\n"; + $self->ipc->killall($sig); + + if ($self->{+SIGNAL}) { + print STDERR "\nSecond signal ($self->{+SIGNAL} followed by $sig), exiting now without waiting\n"; + exit 1; + } + + $self->{+SIGNAL} = $sig; +} + +sub monitor_preloads { 0 } + +sub run { + my $self = shift; + + my $settings = $self->settings; + my $plugins = $self->settings->harness->plugins; + + if ($self->start()) { + $self->render(); + $self->stop(); + + my $final_data = $self->{+FINAL_DATA} or die "Final data never received from auditor!\n"; + my $pass = $self->{+TESTS_SEEN} && $final_data->{pass}; + $self->render_final_data($final_data); + $self->produce_summary($pass); + + if (@$plugins) { + my %args = ( + settings => $settings, + final_data => $final_data, + pass => $pass ? 1 : 0, + tests_seen => $self->{+TESTS_SEEN} // 0, + asserts_seen => $self->{+ASSERTS_SEEN} // 0, + ); + $_->finish(%args) for @$plugins; + } + + return $pass ? 0 : 1; + } + + $self->stop(); + + return 1; +} + +sub DESTROY { + my $self = shift; + + local ($?, $!, $@, $_); + + my $cleanup = delete $self->{+CLEANUP_SUBS} or return; + for my $sub (@$cleanup) { + eval { $sub->(); 1 } or warn $@; + } +} + +sub write_test_info { + my $self = shift; + + return if $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO}; + + my $info_file = "./.test_info.$$.json"; + + my $workdir = $self->workdir; + Test2::Harness::Util::File::JSON->new(name => $info_file)->write({ + workdir => $self->workdir, + job_count => $self->job_count, + }); + + push @{$self->{+CLEANUP_SUBS}} => sub { + return unless -e $info_file; + return unless Test2::Harness::Util::File::JSON->new(name => $info_file)->read->{workdir} eq $workdir; + unlink($info_file) or die "Could not unlink info file: $!"; + }; + + $ENV{TEST2_HARNESS_NO_WRITE_TEST_INFO} = 1; +} + +sub start { + my $self = shift; + + $self->all_state->transaction(w => sub { 1 }); + + $self->ipc->start(); + $self->parse_args; + + $self->write_test_info(); + my $pop = $self->populate_queue(); + $self->terminate_queue(); + + return unless $pop; + + $self->setup_plugins(); + $self->setup_resources(); + + $self->start_runner(jobs_todo => $pop); + $self->start_collector(); + $self->start_auditor(); + + return 1; +} + +sub render { + my $self = shift; + + my $ipc = $self->ipc; + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + my $plugins = $self->settings->harness->plugins; + + my $handle_plugins = [grep { $_->can('handle_event') } @$plugins]; + my $annotate_plugins = [grep { $_->can('annotate_event') } @$plugins]; + + # render results from log + my $reader = $self->renderer_reader(); + $reader->blocking(0); + my $buffer; + while (1) { + return if $self->{+SIGNAL}; + $_->step for @{$renderers}; + + my $line = <$reader>; + unless(defined $line) { + $ipc->wait() if $ipc; + sleep 0.02; + next; + } + + if ($buffer) { + $line = $buffer . $line; + $buffer = undef; + } + + unless (substr($line, -1, 1) eq "\n") { + $buffer //= ""; + $buffer .= $line; + next; + } + + my $e = decode_json($line); + + if (defined $e) { + bless($e, 'Test2::Harness::Event'); + my $fd = $e->{facet_data} //= {}; + + my $changed = 0; + for my $p (@$annotate_plugins) { + my %inject = $p->annotate_event($e, $settings); + next unless keys %inject; + $changed++; + + # Can add new facets, but not modify existing ones. + # Someone could force the issue by modifying the event directly + # inside 'annotate_event', this is not supported, but also not + # forbidden, user beware. + for my $f (keys %inject) { + if (exists $fd->{$f}) { + if ('ARRAY' eq ref($fd->{$f})) { + push @{$fd->{$f}} => @{$inject{$f}}; + } + else { + warn "Plugin '$p' tried to add facet '$f' via 'annotate_event()', but it is already present and not a list, ignoring plugin annotation.\n"; + } + } + else { + $fd->{$f} = $inject{$f}; + } + } + + } + + if ($logger) { + if ($changed) { + my $newline = $e->as_json; + print $logger $newline, "\n"; + } + else { + print $logger $line; + } + } + } + else { + last; + } + + if (my $final = $e->{facet_data}->{harness_final}) { + $self->{+FINAL_DATA} = $final; + } + $_->render_event($e) for @$renderers; + + $self->{+TESTS_SEEN}++ if $e->{facet_data}->{harness_job_launch}; + $self->{+ASSERTS_SEEN}++ if $e->{facet_data}->{assert}; + + $_->handle_event($e, $settings) for @$handle_plugins; + + $ipc->wait() if $ipc; + } +} + +sub get_job_pid { + my $self = shift; + my ($run_id, $job_id) = @_; + + return undef unless $run_id && $job_id; + + my $jdata = $self->{+ALL_STATE}->data->jobs->{$self->{+RUN_ID}} or return undef; + my $list = $jdata->{list} or return undef; + + my $found; + for my $task (@$list) { + next unless $task->{job_id} && $task->{job_id} eq $job_id; + $found = $task; + # Do not end loop early, we want the last matching entry in cases of re-run + } + + return undef unless $found; + + return $found->{pid} // undef; +} + +sub stop { + my $self = shift; + + my $settings = $self->settings; + my $renderers = $self->renderers; + my $logger = $self->logger; + + $self->teardown_plugins($renderers, $logger); + if ($logger) { + print $logger "null\n"; + close($logger); + } + + $_->finish() for @$renderers; + + my $ipc = $self->ipc; + print STDERR "Waiting for child processes to exit...\n" if $self->{+SIGNAL}; + + if ($self->{+SIGNAL}) { + my $state = $self->state; + delete $state->{no_poll}; + $state->poll; + my $running = $state->running_tasks; + $state->halt_run($self->{+RUN_ID}); + + for my $task (values %$running) { + next unless $task->{run_id} && $task->{run_id} eq $self->{+RUN_ID}; + my $pid = $self->get_job_pid($task->{run_id}, $task->{job_id}) // next; + my $file = $task->{rel_file}; + print "Killing test $pid - $file...\n"; + kill('INT', $pid); + } + } + + $ipc->wait(all => 1); + $ipc->stop; + + unless ($settings->display->quiet > 2) { + printf STDERR "\nNo tests were seen!\n" unless $self->{+TESTS_SEEN}; + + printf("\nKeeping work dir: %s\n", $self->workdir) + if $settings->debug->keep_dirs; + + if ($settings->logging->log) { + print "\n"; + print "Wrote log file: " . $settings->logging->log_file . "\n"; + print " (Symlinked to: " . $self->{+LAST_LOG} . ")\n"; + } + + $self->finalize_plugins(); + } +} + +sub terminate_queue { + my $self = shift; + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + $queue->{$_}->{closed} = 1 for keys %$queue; + }); + + $self->state->end_queue(); +} + +sub build_run { + my $self = shift; + + return $self->{+RUN} if $self->{+RUN}; + + my $settings = $self->settings; + my $dir = $self->workdir; + + my $run = $settings->build(run => 'Test2::Harness::Run'); + + mkdir($run->run_dir($dir)) or die "Could not make run dir: $!"; + chmod_tmp($dir); + + return $self->{+RUN} = $run; +} + +sub all_state { + my $self = shift; + + $self->{+ALL_STATE} //= Test2::Harness::State->new( + workdir => $self->workdir, + job_count => $self->job_count, + settings => $self->settings, + ); +} + +sub state { + my $self = shift; + + my $all_state = $self->all_state; + + $self->{+STATE} //= Test2::Harness::Runner::State->new( + state => $all_state, + workdir => $self->workdir, + job_count => $self->job_count, + no_poll => 1, + ); +} + +sub job_count { + my $self = shift; + + return $self->settings->runner->job_count; +} + +sub finder_args {()} + +sub populate_queue { + my $self = shift; + + my $run = $self->build_run(); + $self->{+RUN_ID} = $run->run_id; + my $settings = $self->settings; + my $finder = $settings->build(finder => $settings->finder->finder, $self->finder_args); + + my $state = $self->state; + my $plugins = $settings->harness->plugins; + + $state->queue_run($run->queue_item($plugins)); + + my @files = @{$finder->find_files($plugins, $self->settings)}; + + for my $plugin (@$plugins) { + if ($plugin->can('sort_files_2')) { + @files = $plugin->sort_files_2(settings => $settings, files => \@files); + } + elsif ($plugin->can('sort_files')) { + @files = $plugin->sort_files(@files); + } + } + + my @add_to_queue; + + my $job_count = 0; + for my $file (@files) { + my $task = $file->queue_item(++$job_count, $run->run_id, + $settings->check_prefix('display') ? (verbose => $settings->display->verbose) : (), + ); + + $task->{category} = 'isolation' if $settings->debug->interactive; + + $state->queue_task($task); + + push @add_to_queue => $task; + } + + $self->all_state->transaction(w => sub { + my ($state, $data) = @_; + my $queue = $data->queue; + push @{$queue->{$self->{+RUN_ID}}->{list} //= []} => @add_to_queue; + }); + + $state->stop_run($run->run_id); + + return $job_count; +} + +sub produce_summary { + my $self = shift; + my ($pass) = @_; + + my $settings = $self->settings; + + my $time_data = { + start => $settings->harness->start, + stop => time(), + }; + + $time_data->{wall} = $time_data->{stop} - $time_data->{start}; + + my @times = times(); + @{$time_data}{qw/user system cuser csystem/} = @times; + $time_data->{cpu} = sum @times; + + my $cpu_usage = int($time_data->{cpu} / $time_data->{wall} * 100); + + $self->write_summary($pass, $time_data, $cpu_usage); + $self->render_summary($pass, $time_data, $cpu_usage); +} + +sub write_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + my $file = $self->settings->debug->summary or return; + + my $final_data = $self->{+FINAL_DATA}; + + my $failures = @{$final_data->{failed} // []}; + + my %data = ( + %$final_data, + + pass => $pass ? JSON->true : JSON->false, + + total_failures => $failures // 0, + total_tests => $self->{+TESTS_SEEN} // 0, + total_asserts => $self->{+ASSERTS_SEEN} // 0, + + cpu_usage => $cpu_usage, + + times => $time_data, + ); + + require Test2::Harness::Util::File::JSON; + my $jfile = Test2::Harness::Util::File::JSON->new(name => $file); + $jfile->write(\%data); + + print "\nWrote summary file: $file\n\n"; + + return; +} + +sub render_summary { + my $self = shift; + my ($pass, $time_data, $cpu_usage) = @_; + + return if $self->settings->display->quiet > 1; + + my $final_data = $self->{+FINAL_DATA}; + my $failures = @{$final_data->{failed} // []}; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $self->{+TESTS_SEEN}", + "Assertion Count: $self->{+ASSERTS_SEEN}", + $time_data ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->settings->display->color && USE_ANSI_COLOR) { + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + +sub render_final_data { + my $self = shift; + my ($final_data) = @_; + + return if $self->settings->display->quiet > 1; + + if (my $rows = $final_data->{retried}) { + print "\nThe following jobs failed at least once:\n"; + print join "\n" => table( + header => ['Job ID', 'Times Run', 'Test File', "Succeeded Eventually?"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{failed}) { + print "\nThe following jobs failed:\n"; + print join "\n" => table( + collapse => 1, + header => ['Job ID', 'Test File', 'Subtests'], + rows => [map { my $r = [@{$_}]; $r->[2] = stringify_subtest_map($r->[2]) if $r->[2]; $r} @$rows], + ); + print "\n"; + } + + if (my $rows = $final_data->{halted}) { + print "\nThe following jobs requested all testing be halted:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File', "Reason"], + rows => $rows, + ); + print "\n"; + } + + if (my $rows = $final_data->{unseen}) { + print "\nThe following jobs never ran:\n"; + print join "\n" => table( + header => ['Job ID', 'Test File'], + rows => $rows, + ); + print "\n"; + } +} + +sub stringify_subtest_map { + my ($map) = @_; + + my $out = ""; + my @todo = @$map; + my @state; + while (my $st = shift @todo) { + if (!ref($st)) { + pop @state if $st eq 'pop'; + next; + } + push @state => $st->[0]; + $out .= join(' -> ' => @state) . "\n"; + unshift @todo => (@{$st->[1]}, 'pop'); + } + + return $out; +} + +sub logger { + my $self = shift; + + return $self->{+LOGGER} if $self->{+LOGGER}; + + my $settings = $self->{+SETTINGS}; + + return unless $settings->logging->log; + + my $file = $settings->logging->log_file; + + if ($settings->logging->bzip2) { + no warnings 'once'; + require IO::Compress::Bzip2; + $self->{+LOGGER} = IO::Compress::Bzip2->new($file) or die "Could not open log file '$file': $IO::Compress::Bzip2::Bzip2Error"; + } + elsif ($settings->logging->gzip) { + no warnings 'once'; + require IO::Compress::Gzip; + $self->{+LOGGER} = IO::Compress::Gzip->new($file) or die "Could not open log file '$file': $IO::Compress::Gzip::GzipError"; + } + else { + $self->{+LOGGER} = open_file($file, '>'); + } + + for my $ext ('jsonl', 'jsonl.bz2', 'jsonl.gz') { + my $name = "./lastlog.$ext"; + next unless -f $name; + local ($!, $@) = (0, ''); + eval { unlink($name) } or warn "Could not unlink '$name': ($!) $@"; + } + + if ($file =~ m/\.(jsonl(?:\.(?:bz2|gz))?)$/) { + my $ext = $1; + my $name = "./lastlog.$ext"; + if (eval { symlink($file, $name); 1 }) { + $self->{+LAST_LOG} = $name; + } + else { + warn "Could not symlink the log file to '$name': $@"; + } + } + + return $self->{+LOGGER}; +} + +sub renderers { + my $self = shift; + + return $self->{+RENDERERS} if $self->{+RENDERERS}; + + my $settings = $self->{+SETTINGS}; + + my @renderers; + for my $class (@{$settings->display->renderers->{'@'}}) { + require(mod2file($class)); + my $args = $settings->display->renderers->{$class}; + my $renderer = $class->new(@$args, settings => $settings, command_class => ref($self)); + push @renderers => $renderer; + } + + return $self->{+RENDERERS} = \@renderers; +} + +sub start_auditor { + my $self = shift; + + my $run = $self->build_run(); + my $settings = $self->settings; + + my $ipc = $self->ipc; + $ipc->spawn( + stdin => $self->auditor_reader(), + stdout => $self->auditor_writer(), + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + auditor => 'Test2::Harness::Auditor', + $run->run_id, + procname_prefix => $settings->debug->procname_prefix, + ], + ); + + close($self->auditor_writer()); +} + +sub collector_options { () } + +sub start_collector { + my $self = shift; + + my $dir = $self->workdir; + my $run = $self->build_run(); + my $settings = $self->settings; + my $runner_pid = $self->runner_pid; + + my ($rh, $wh); + pipe($rh, $wh) or die "Could not create pipe"; + + my %options = (show_runner_output => 1); + if ($settings->check_prefix('display')) { + $options{show_runner_output} = $settings->display->hide_runner_output ? 0 : 1; + $options{truncate_runner_output} = $settings->display->truncate_runner_output; + } + + %options = ( + %options, + $self->collector_options(), + ); + + my $ipc = $self->ipc; + $ipc->spawn( + stdout => $self->collector_writer, + stdin => $rh, + no_set_pgrp => 1, + command => [ + $^X, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + collector => 'Test2::Harness::Collector', + $dir, $run->run_id, $runner_pid, + %options, + ], + ); + + close($rh); + print $wh encode_json($run) . "\n"; + close($wh); + + close($self->collector_writer()); +} + +sub start_runner { + my $self = shift; + my %args = @_; + + $args{monitor_preloads} //= $self->monitor_preloads; + + my $settings = $self->settings; + my $dir = $settings->workspace->workdir; + + my @prof; + if ($settings->runner->nytprof) { + push @prof => '-d:NYTProf'; + } + + my $ipc = $self->ipc; + my $proc = $ipc->spawn( + stderr => File::Spec->catfile($dir, 'error.log'), + stdout => File::Spec->catfile($dir, 'output.log'), + env_vars => { @prof ? (NYTPROF => 'start=no:addpid=1') : () }, + no_set_pgrp => 1, + command => [ + $^X, @prof, $self->spawn_args($settings), $settings->harness->script, + (map { "-D$_" } @{$settings->harness->dev_libs}), + '--no-scan-plugins', # Do not preload any plugin modules + runner => $dir, + %args, + ], + ); + + $self->{+RUNNER_PID} = $proc->pid; + + return $proc; +} + +sub parse_args { + my $self = shift; + my $settings = $self->settings; + my $args = $self->args; + + my $dest = $settings->finder->search; + for my $arg (@$args) { + next if $arg eq '--'; + if ($arg eq '::') { + $dest = $settings->run->test_args; + next; + } + + push @$dest => $arg; + } + + return; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/times.pm b/liby/App/Yath/Command/times.pm new file mode 100644 index 000000000..c5e2538f0 --- /dev/null +++ b/liby/App/Yath/Command/times.pm @@ -0,0 +1,150 @@ +package App::Yath::Command::times; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Times qw/render_duration/; + +use Test2::Harness::Util::File::JSONL; + +use App::Yath::Options; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase qw/-log_file <fields/; + +include_options( + 'App::Yath::Options::Debug', +); + +sub summary { "Get times from a test log" } + +sub group { 'log' } + +sub cli_args { "[--] event_log.jsonl[.gz|.bz2] [Field1] [Field2]" } + +sub description { + return <<" EOT"; +This command will consume the log of a previous run, and output all timing data +from shortest test to longest. You can specify a sort order by listing fields +in your desired order after the log file on the command line. + EOT +} + +my @NUMERIC = qw/total startup events cleanup/; +my %NUMERIC = map { $_ => 1 } @NUMERIC; + +my @ALPHA = qw/file/; +my %ALPHA = map { $_ => 1 } @ALPHA; + +my @FIELDS = (@NUMERIC, @ALPHA); +my %FIELDS = map { $_ => 1 } @FIELDS; + +sub run { + my $self = shift; + + my $args = $self->args; + + shift @$args if @$args && $args->[0] eq '--'; + + $self->{+LOG_FILE} = shift @$args or die "You must specify a log file"; + die "'$self->{+LOG_FILE}' is not a valid log file" unless -f $self->{+LOG_FILE}; + die "'$self->{+LOG_FILE}' does not look like a log file" unless $self->{+LOG_FILE} =~ m/\.jsonl(\.(gz|bz2))?$/; + + my %seen; + my @fields; + for my $field (@$args, @FIELDS) { + $field = lc($field); + next if $seen{$field}++; + die "'$field' is not a valid field\n" unless $FIELDS{$field}; + push @fields => $field; + } + + $self->{+FIELDS} = \@fields; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $self->{+LOG_FILE}); + + my @jobs; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $stamp = $event->{stamp} or next; + my $job_id = $event->{job_id} or next; + my $f = $event->{facet_data} or next; + + next unless $f->{harness_job_end}; + + my $job = {}; + $job->{file} = $f->{harness_job_end}->{rel_file} if $f->{harness_job_end} && $f->{harness_job_end}->{rel_file}; + $job->{time} = $f->{harness_job_end}->{times}->{totals} if $f->{harness_job_end} && $f->{harness_job_end}->{times}; + + push @jobs => $job; + } + } + + my @rows; + my $totals = {file => 'TOTAL'}; + + @jobs = sort { $self->sort_compare($a, $b) } @jobs; + + for my $job (@jobs) { + my $data = $job->{time}; + push @rows => $self->build_row({%$data, file => $job->{file}}); + $totals->{$_} += $data->{$_} for @NUMERIC; + } + + push @rows => [map { '--' } @fields]; + push @rows => $self->build_row($totals); + + require Term::Table; + my $table = Term::Table->new( + header => [map { ucfirst($_) } @fields], + rows => \@rows, + ); + + print "$_\n" for $table->render; + + return 0; +} + +sub build_row { + my $self = shift; + my ($data) = @_; + + return [map { $NUMERIC{$_} && defined($data->{$_}) ? render_duration($data->{$_}) : $data->{$_} } @{$self->{+FIELDS}}]; +} + +sub sort_compare { + my $self = shift; + my ($ja, $jb) = @_; + + my $order = $self->{+FIELDS}; + + my $ta = $ja->{time}; + my $tb = $jb->{time}; + + for my $field (@$order) { + my $fa = $ta->{$field}; + my $fb = $tb->{$field}; + + my $da = defined $fa; + my $db = defined $fb; + + next unless $da || $db; + return 1 if $da && !$db; + return -1 if $db && !$da; + + my $delta = $ALPHA{$field} ? lc($fa) cmp lc($fb) : $fa <=> $fb; + return $delta if $delta; + } + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/watch.pm b/liby/App/Yath/Command/watch.pm new file mode 100644 index 000000000..edd935c63 --- /dev/null +++ b/liby/App/Yath/Command/watch.pm @@ -0,0 +1,100 @@ +package App::Yath::Command::watch; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/sleep/; + +use Test2::Harness::Util::File::JSON; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/open_file/; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Monitor the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This command will tail the logs from a persistent instance of yath. STDOUT and +STDERR will be printed as seen, so may not be in proper order. + EOT +} + +sub run { + my $self = shift; + + my $args = $self->args; + shift @$args if @$args && $args->[0] eq '--'; + my $stop = 1 if @$args && $args->[0] eq 'STOP'; + + my $pfile = find_pfile($self->settings, no_fatal => 1) + or die "No persistent harness was found for the current path.\n"; + + print "\nFound: $pfile\n"; + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + print "\n"; + + my $err_f = File::Spec->catfile($data->{dir}, 'error.log'); + my $out_f = File::Spec->catfile($data->{dir}, 'output.log'); + + my $err_fh = open_file($err_f, '<'); + my $out_fh = open_file($out_f, '<'); + + my $auxdir = File::Spec->catdir($data->{dir}, 'aux_logs'); + my %aux; + + while (1) { + my $count = 0; + while (my $line = <$out_fh>) { + $count++; + print STDOUT $line; + } + while (my $line = <$err_fh>) { + $count++; + print STDERR $line; + } + + if (-d $auxdir) { + opendir(my $dh, $auxdir) or die "Could not open auxdir: $!"; + for my $file (readdir($dh)) { + next if $aux{$file}; + next unless $file =~ m/\.log$/; + my $full = File::Spec->catfile($auxdir, $file); + next unless -f $full; + $aux{$file} = open_file($full, '<'); + $count++; + } + } + + for my $file (sort keys %aux) { + my $fh = $aux{$file}; + my $ofh = $file =~ m/STDERR/ ? \*STDERR : \*STDOUT; + while (my $line = <$fh>) { + print $ofh $line; + } + } + + next if $count; + last if $stop; + last unless -f $pfile; + sleep 0.02; + } + + return 0; +} + + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Command/which.pm b/liby/App/Yath/Command/which.pm new file mode 100644 index 000000000..53c94eb8b --- /dev/null +++ b/liby/App/Yath/Command/which.pm @@ -0,0 +1,49 @@ +package App::Yath::Command::which; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; + +use Test2::Harness::Util::File::JSON; + +use parent 'App::Yath::Command'; +use Test2::Harness::Util::HashBase; + +sub group { 'persist' } + +sub summary { "Locate the persistent test runner" } +sub cli_args { "" } + +sub description { + return <<" EOT"; +This will tell you about any persistent runners it can find. + EOT +} + +sub run { + my $self = shift; + + my $pfile = find_pfile($self->settings, no_fatal => 1); + + unless ($pfile) { + print "\nNo persistent harness was found for the current path.\n\n"; + return 0; + } + + print "\nFound: $pfile\n"; + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + print " PID: $data->{pid}\n"; + print " Dir: $data->{dir}\n"; + print "\n"; + + return 0; +} + +1; + +__END__ + +=head1 POD IS AUTO-GENERATED + diff --git a/liby/App/Yath/Converting.pm b/liby/App/Yath/Converting.pm new file mode 100644 index 000000000..a0dce16f5 --- /dev/null +++ b/liby/App/Yath/Converting.pm @@ -0,0 +1,105 @@ +package App::Yath::Converting; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Converting - Things you may need to change in your tests before you can use yath. + +=head1 NON-TAP FORMATTER + +By default yath tells any L<Test2> or L<Test::Builder> tests to use +L<Test2::Formatter::Stream> instead of L<Test2::Formatter::TAP>. This is done +in order to make sure as much data as possible makes it to yath, TAP is a lossy +formater by comparison. + +This is not normally a problem, but tests that do strange things with +STDERR/STDOUT, or try to intercept output from the regular TAP formatter can +have issues with this. + +=head2 SOLUTIONS + +=head3 HARNESS-NO-STREAM + +You can add a harness directive to the top of offending tests that tell the +harness those specific tests should still use the TAP formatter. + + #!/usr/bin/perl + # HARNESS-NO-STREAM + ... + +This directive can come after the C<#!> line, and after use statements, but +must come BEFORE any empty lines or runtime statements. + +=head3 --no-stream + +You can run yath with the C<--no-stream> option, which will have tests default +to TAP. This is not recommended as TAP is lossy. + +=head1 TESTS ARE RUN VIA FORK BY DEFAULT + +The default mode for yath is to preload a few things, then fork to spawn each +test. This is a complicated procedure, and it uses L<goto::file> under the +hood. Sometimes you have tests that simply will not work this way, or tests +that verify specific libraries are not already loaded. + +=head2 SOLUTIONS + +=head3 HARNESS-NO-PRELOAD + +You can use this harness directive inside your tests to tell yath not to fork, +but to instead launch a new perl process to run the test. + + #!/usr/bin/perl + # HARNESS-NO-PRELOAD + ... + +=head3 --no-fork + +=head3 --no-preload + +Both these options tell yath not to preload+fork, but to run ALL tests in new +processes. This is slow, it is better to mark specific tests that have issues +in preload mode. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Option.pm b/liby/App/Yath/Option.pm new file mode 100644 index 000000000..5cfac4cba --- /dev/null +++ b/liby/App/Yath/Option.pm @@ -0,0 +1,1157 @@ +package App::Yath::Option; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use Test2::Harness::Util::HashBase qw{ + <title + <field <name <type <trace + <ignore_for_build + + <prefix <short <alt + + <pre_command <from_plugin <from_command + + <pre_process + <adds_options + + <default <normalize <action <negate <autofill + <env_vars <clear_env_vars + + +applicable + + <builds + <category + <description + <short_examples <long_examples +}; + +my %TYPES = ( + b => 1, + c => 1, + s => 1, + m => 1, + d => 1, + D => 1, + h => 1, + H => 1, +); +sub valid_type { $TYPES{$_[-1]} } + +my %LONG_TO_SHORT_TYPES = ( + bool => 'b', + boolean => 'b', + + count => 'c', + counter => 'c', + counting => 'c', + + scalar => 's', + string => 's', + number => 's', + + multi => 'm', + multiple => 'm', + list => 'm', + array => 'm', + + default => 'd', + def => 'd', + + 'multi-def' => 'D', + 'multiple-default' => 'D', + 'list-default' => 'D', + 'array-default' => 'D', + + 'hash' => 'h', + 'hash-list' => 'H', +); +sub canon_type { $LONG_TO_SHORT_TYPES{$_[-1]} } + +my %REQUIRES_ARG = (s => 1, m => 1, h => 1, H => 1); +sub requires_arg { $REQUIRES_ARG{$_[0]->{+TYPE}} } + +my %ALLOWS_ARG = (d => 1, D => 1); +sub allows_arg { $ALLOWS_ARG{$_[0]->{+TYPE}} || $REQUIRES_ARG{$_[0]->{+TYPE} } } + +sub init { + my $self = shift; + + confess "You must specify 'title' or both 'field' and 'name'" + unless $self->{+TITLE} || ($self->{+FIELD} && $self->{+NAME}); + + confess "The 'prefix' attribute is required" + unless $self->{+PREFIX}; + + confess "The 'alt' attribute must be an array-ref" + if $self->{+ALT} && ref($self->{+ALT}) ne 'ARRAY'; + + if (my $title = $self->{+TITLE}) { + $self->{+FIELD} //= $title; + $self->{+NAME} //= ($self->{+FROM_PLUGIN} && $self->{+PREFIX}) ? "$self->{+PREFIX}-$title" : $title; + } + + $self->{+FIELD} =~ s/-/_/g; + $self->{+NAME} =~ s/_/-/g; + + if (my $class = $self->{+BUILDS}) { + confess "class '$class' does not have a '$self->{+FIELD}' method" + unless $class->can($self->{+FIELD}) || $self->{+IGNORE_FOR_BUILD}; + } + + $self->{+TYPE} //= 'b'; + $self->{+TYPE} = $self->canon_type($self->{+TYPE}) // $self->{+TYPE} if length($self->{+TYPE}) > 1; + confess "Invalid type '$self->{+TYPE}'" unless $self->valid_type($self->{+TYPE}); + + if ($self->{+TYPE} eq 'd' || $self->{+TYPE} eq 'D') { + $self->{+AUTOFILL} //= 1; + } + elsif(defined $self->{+AUTOFILL}) { + confess "'autofill' not supported for this type ('$self->{+TYPE}')"; + } + + if (my $def = $self->{+DEFAULT}) { + my $ref = ref($def); + confess "'default' must be a simple scalar, or a coderef, got a '$ref'" if $ref && $ref ne 'CODE'; + } + + for my $key (NORMALIZE(), ACTION()) { + my $val = $self->{$key} or next; + my $ref = ref($val) || 'not a ref'; + next if $ref eq 'CODE'; + confess "'$key' must be undef, or a coderef, got '$ref'"; + } + + $self->{+TRACE} //= [caller(1)]; + $self->{+CATEGORY} //= 'NO CATEGORY - FIX ME'; + $self->{+DESCRIPTION} //= 'NO DESCRIPTION - FIX ME'; + + for my $key (sort keys %$self) { + confess "'$key' is not a valid option attribute" + unless $self->can(uc($key)); + } + + return $self; +} + +sub applicable { + my $self = shift; + my ($options) = @_; + my $cb = $self->{+APPLICABLE} or return 1; + return $self->$cb($options); +} + +sub long_args { + my $self = shift; + + return ($self->{+NAME}, @{$self->{+ALT} || []}); +} + +sub option_slot { + my $self = shift; + my ($settings) = @_; + + confess "A settings instance is required" unless $settings; + return $settings->define_prefix($self->{+PREFIX})->vivify_field($self->{+FIELD}); +} + +sub get_default { + my $self = shift; + + for my $var (@{$self->{+ENV_VARS} // []}) { + my ($neg) = $var =~ s/^(!)//; + next unless exists $ENV{$var}; + return !$ENV{$var} if $neg; + return $ENV{$var}; + } + + if (defined $self->{+DEFAULT}) { + my $def = $self->{+DEFAULT}; + + return $self->$def() if ref($def); + + return $def; + } + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return undef; +} + +sub get_normalized { + my $self = shift; + my ($raw) = @_; + + return $self->{+NORMALIZE}->($raw) + if $self->{+NORMALIZE}; + + return $raw ? 1 : 0 + if $self->{+TYPE} eq 'b'; + + if (lc($self->{+TYPE}) eq 'h') { + my ($key, $val) = split /=/, $raw, 2; + + if ($self->{+TYPE} eq 'H') { + $val //= ''; + $val = [split /,/, $val]; + return [$key, $val]; + } + + return [$key, $val // 1]; + } + + return $raw; +} + +my %HANDLERS = ( + c => sub { ${$_[0]}++ }, + m => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + D => sub { push @{${$_[0]} //= []} => $_[1] && ref($_[1]) eq 'ARRAY' ? @{$_[1]} : $_[1] }, + h => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $val = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + $hash->{$key} = $val; + }, + H => sub { + my $hash = ${$_[0]} //= {}; + my $key = $_[1]->[0]; + my $vals = $_[1]->[1]; + + push @{$hash->{'@'} //= []} => $key unless $hash->{$key}; + push @{$hash->{$key} //= []} => @$vals; + }, +); + +sub handle { + my $self = shift; + my ($raw, $settings, $options, $list) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + my $norm = $self->get_normalized($raw); + + my $handler = $HANDLERS{$self->{+TYPE}} //= sub { ${$_[0]} = $_[1] }; + + return $self->{+ACTION}->($self->{+PREFIX}, $self->{+FIELD}, $raw, $norm, $slot, $settings, $handler, $options) + if $self->{+ACTION}; + + return $handler->($slot, $norm); +} + +sub handle_negation { + my $self = shift; + my ($settings, $options) = @_; + + confess "A settings instance is required" unless $settings; + confess "An options instance is required" unless $options; + + my $slot = $self->option_slot($settings); + + return $self->{+NEGATE}->($self->{+PREFIX}, $self->{+FIELD}, $slot, $settings, $options) + if $self->{+NEGATE}; + + return $$slot = 0 + if $self->{+TYPE} eq 'b' + || $self->{+TYPE} eq 'c'; + + return @{$$slot //= []} = () + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return %{$$slot //= {}} = () + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + return $$slot = undef; +} + +sub trace_string { + my $self = shift; + my $trace = $self->{+TRACE} or return "[UNKNOWN]"; + return "$trace->[1] line $trace->[2]"; +} + +my %TYPE_LONG_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]'], + D => ['[=ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_SHORT_ARGS = ( + b => [''], + c => [''], + s => [' ARG', '=ARG'], + m => [' ARG', '=ARG'], + d => ['[=ARG]', '[ARG]'], + D => ['[=ARG]', '[ARG]'], + h => [' KEY=VAL', '=KEY=VAL'], + H => [' KEY=VAL1,VAL2,...', '=KEY=VAL1,VAL2,...'], +); + +my %TYPE_NOTES = ( + 'c' => "Can be specified multiple times", + 'm' => "Can be specified multiple times", + 'D' => "Can be specified multiple times", + 'h' => "Can be specified multiple times", + 'H' => "Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together.", +); + +sub cli_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + + push @forms => "--no-$self->{+NAME}"; + + my @out; + + require App::Yath::Util; + require Test2::Util::Term; + + my $width = Test2::Util::Term::term_size() - 20; + $width = 80 unless $width && $width >= 80; + + push @out => App::Yath::Util::fit_to_width($width, ", ", \@forms); + + my $desc = App::Yath::Util::fit_to_width($width, " ", $self->{+DESCRIPTION}); + $desc =~ s/^/ /gm; + push @out => $desc; + + push @out => "\n Can also be set with the following environment variables: " . join(", ", @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => "\n Note: " . $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join "\n" => @out; +} + +sub pod_docs { + my $self = shift; + + my @forms = (map { "--$self->{+NAME}$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + for my $alt (@{$self->{+ALT} || []}) { + push @forms => (map { "--$alt$_" } @{$self->{+LONG_EXAMPLES} || $TYPE_LONG_ARGS{$self->{+TYPE}}}); + } + push @forms => map { "-$self->{+SHORT}$_" } @{$self->{+SHORT_EXAMPLES} || $TYPE_SHORT_ARGS{$self->{+TYPE}}} + if $self->{+SHORT}; + push @forms => "--no-$self->{+NAME}"; + + my @out = map { "=item $_" } @forms; + + push @out => $self->{+DESCRIPTION}; + + push @out => "Can also be set with the following environment variables: " . join(", ", map { "C<$_>" } @{$self->{+ENV_VARS}}) if $self->{+ENV_VARS}; + + push @out => $TYPE_NOTES{$self->{+TYPE}} if $TYPE_NOTES{$self->{+TYPE}}; + + return join("\n\n" => @out) . "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Option - Representation of a yath option. + +=head1 DESCRIPTION + +This class represents a single command line option for yath. + +=head1 SYNOPSIS + +You usually will not be creating option instances directly. Usually you will +use App::Yath::Options which provides sugar, and helps make sure options get to +the right place. + + use App::Yath::Options; + + # You can specify a single option: + option color => ( + prefix => 'display', + category => "Display Options", + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + # If you are specifying multiple options you can use an option_group to + # define common parameters. + option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + }; + +=head1 ATTRIBUTES + +These can be provided at object construction, or are generated internally. + +=head2 CONSTRUCTION ONLY + +=over 4 + +=item applicable => sub { ... } + +This is callback is used by the C<applicable()> method. + + option foo => ( + ..., + applicable => sub { + my ($opt, $options) = @_; + ... + return $bool; + }, + ); + +=back + +=head2 READ-ONLY + +=head3 REQUIRED + +=over 4 + +=item $class->new(prefix => 'my_prefix') + +=item $scalar = $opt->prefix() + +A prefix is required. All options have their values inserted into the settings +structure, an instance of L<Test2::Harness::Settings>. The structure is +C<< $settings->PREFIX->OPTION >>. + +If you do not specify a C<name> attribute then the default name will be +C<PREFIX-TITLE>. The name is the main command line argument, so +C<--PREFIX-TITLE> is the default name. + +=item $class->new(type => $type) + +=item $type = $opt->type() + +All options must have a type, if non is specified the default is C<'b'> aka +boolean. + +Here are all the possible types, along with their aliases. You may use the type +character, or any of the aliases to specify that type. + +=over 4 + +=item b bool boolean + +True of false values, will be normalized to 0 or 1 in most cases. + +=item c count counter counting + +Counter, starts at 0 and then increments every time the option is used. + +=item s scalar string number + +Requires an argument which is treated as a scalar value. No type checking is +done by the option itself, though you can check it using C<action> or +C<normalize> callbacks which are documented under those attributes. + +=item m multi multiple list array + +Requires an argument which is treated as a scalar value. Can be used multiple +times. All arguments provided are appended to an array. + +=item d def default + +Argument is optional, scalar when provided. C<--opt=arg> to provide an +argument, C<--opt arg> will not work, C<arg> will be seen as its own item on +the command line. Can be specified without an arg C<--opt> to signify a default +argument should be used (set via the C<action> callback, not the C<default> +attribute which is a default value regardless of if the option is used.) + +Real world example from the debug options (simplified for doc purposes): + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + # New way to specify an auto-fill value for when no =VAL is provided. + # If you do not specify this the default autofill is '1' for legacy support. + autofill => 'VALUE', + + # Old way to autofill a value (default is 1 for auto-fill) + # Using autofill is significantly better. + # You can also use action for additional behavior along with autofill, + # but the default will be your auto-fill value, not '1'. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # $norm will be '1' if option was used without an argument, so we + # just use the provided value when it is not 1'. + return $$slot = $norm unless $norm eq '1'; + + # $norm was 1, so this is our no-arg "default" behavior + + # Do nothing if a value is already set + return if $$slot; + + # Set the default value of 'summary.json' + return $$slot = 'summary.json'; + }, + ); +}; + +=item D multi-def multiple-default list-default array-default + +This is a combination of C<d> and C<m>. You can use the opt multiple times to +list multiple values, and you can call it without args to add a set of +"default" values (not to be confused with THE default attribute, which is used +even if the option never appears on the command line.) + +Real world example (simplified for doc purposes): + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + # New way to specify the auto-fill values. This may be a single scalar, + # or an arrayref. + autofill => [ 'lib', 'blib/lib', 'blib/arch' ], + + # Old way to specify the auto-fill values. + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + # If no argument was provided use the 'lib', 'blib/lib', and 'blib/arch' defaults. + # If an argument was provided, use it. + push @{$$slot} => ($norm eq '1') ? ('lib', 'blib/lib', 'blib/arch') : ($norm); + }, + ); + +=item h hash + +The hash type. Each time the option is used it is to add a single key/value pair +to the hash. Use an C<=> sign to split the key and value. The option can be +used multiple times. A value is required. + + yath --opt foo=bar --opt baz=bat + +=item H hash-list + +Similar to the 'h' type except the key/value pair expects a comma separated +list for the value, and it will be placed under the key as an arrayef. + + yath --opt foo=a,b,c --opt bar=1,2,3 + +The yath command obove would produce this structure: + + { + foo => ['a', 'b', 'c'], + bar => ['1', '2', '3'], + } + +=back + +=item $class->new(title => 'my_title') + +=item $title = $opt->title() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +If your title is C<'foo-bar_baz'> then your field will be C<'foo_bar_baz'> and +your name will be C<'$PREFIX-foo-bar-baz'>. + +Basically title is used to generate a sane field and/or name if niether are +specified. For field all dashes are changed to underscores. The field is used +as a key in the settings: C<< $settings->prefix->field >>. For the name all +underscores are changed to dashes, if the option is provided by a plugin then +C<'prefix-'> is prepended as well. The name is used for the command line +argument C<'--name'>. + +If you do not want/like the name and field generated from a title then you can +specify a name or title directly. + +=item $class->new(name => 'my-name') + +=item $name = $opt->name() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +This name is used as your primary command line argument. If your name is C<foo> +then your command line argument is C<--foo>. + +=item $class->new(field => 'my_field') + +=item $field = $opt->field() + +You B<MUST> specify either a title, or BOTH a name and field. If you only +specify a title it will be used to generate the name and field. + +The field is used in the settings hash. If your field is C<foo> then your +settings path is C<< $setting->prefix->foo >>. + +=back + +=head3 OPTIONAL + +=over 4 + +=item $class->new(action => sub ...) + +=item $coderef = $opt->action() + + option foo => ( + ..., + action => sub { + my ($prefix, $field_name, $raw_value, $normalized_value, $slot_ref, $settings, $handler, $options) = @_; + + # If no action is specified the following is all that is normally + # done. Having an action means this is not done, so if you want the + # value stored you must call this or similar. + $handler->($slot, $normalized_value); + }, + ); + +=over 4 + +=item $prefix + +The prefix for the option, specified when the option was defined. + +=item $field_name + +The field for the option, specified whent the option was defined. + +=item $raw_value + +The value/argument provided at the command line C<--foo bar> would give us +C<"bar">. This is BEFORE any processing/normalizing is done. + +For options that do not take arguments, or where argumentes are optional and none are provided, this +will be '1'. + +=item $normalized_value + +If a normalize callback was provided this will be the result of putting the +$raw_value through the normalize callback. + +=item $slot_ref + +This is a scalar reference to the settings slot that holds the option value(s). + +The default behavior when no action is specified is usually one of these: + + $$slot_ref = $normalized_value; + push @{$$slot_ref} => $normalized_value; + +However, to save yourself trouble you can use the C<$handler> instead (see below). + +=item $settings + +The L<Test2::Harness::Settings> instance. + +=item $handler + +A callback that "does the right thing" as far as setting the value in the +settings hash. This is what is used when you do not set an action callback. + + $handler->($slot, $normalized_value); + +=item $options + +The L<App::Yath::Options> instance this options belongs to. This is mainly +useful if you have an option that may add even more options (such as the +C<--plugin> option can do). Note that if you do this you should also set the +C<adds_options> attribute to true, if you do not then the options list will not +be refreshed and your new options may not show up. + +=back + +=item $class->new(adds_options => $bool) + +=item $bool = $opt->adds_options() + +If this is true then it means using this option could result in more options +being available (example: Loading a plugin). + +=item $class->new(alt => ['alt1', 'alt2', ...]) + +=item $arrayref = $opt->alt() + +Provide alternative names for the option. These are aliases that can be used to +achieve the same thing on the command line. This is mainly useful for +backcompat if an option is renamed. + +=item $class->new(builds => 'My::Class') + +=item $my_class = $opt->builds() + +If this option is used in the construction of another object (such as the group +it belongs to is composed of options that translate 1-to-1 to fields in another +object to build) then this can be used to specify that. The ultimate effect is +that an exception will be thrown if that class does not have the correct +attribute. This is a safety net to catch errors early if field names change, or +are missing between this representation and the object being composed. + +=item $class->new(category => 'My Category') + +=item $category = $opt->category() + +This is used to sort/display help and POD documentation for your option. If you +do not provide a category it is set to C<'NO CATEGORY - FIX ME'>. The default +value makes sure everyone knows that you do not know what you are doing :-). + +=item $class->new(clear_env_vars => $bool) + +=item $bool = $opt->clear_env_vars() + +This option is only useful when paired with the C<env_vars> attribute. + +Example: + + option foo => ( + ... + env_vars => ['foo', 'bar', 'baz'], + clear_env_vars => 1, + ): + +In this case you are saying option foo can be set to the value of C<$ENV{foo}>, +C<$ENV{bar}>, or C<$ENV{baz}> vars if any are defined. The C<clear_env_vars> +tell it to then delete the environment variables after they are used to set the +option. This is useful if you want to use the env var to set an option, but do +not want any tests to be able to see the env var after it is used to set the +option. + +=item $class->new(default => $scalar) + +=item $class->new(default => sub { return $default }) + +=item $scalar_or_coderef = $opt->default() + +This sets a default value for the field in the settings hash, the default is +set before any command line processing is done, so if the option is never used +in the command line the default value will be there. + +Be sure to use the correct default value for your type. A scalar for 's', an +arrayref for 'm', etc. + +Note, for any non-scalar type you want to use a subref to define the value: + + option foo => ( + ... + type => 'm', + default => sub { [qw/a b c/] }, + ); + +=item $class->new(description => "Fe Fi Fo Fum") + +=item $multiline_string = $opt->description() + +Description of your option. This is used in help output and POD. If you do not +provide a value the default is C<'NO DESCRIPTION - FIX ME'>. + +=item $class->new(env_vars => \@LIST) + +=item $arrayref = $opt->env_vars() + +If set, this should be an arrayref of environment variable names. If any of the +environment variables are defined then the settings will be updated as though +the option was provided onthe command line with that value. + +Example: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + ); + +Then command line: + + FOO="xxx" yath test + +Should be the same as + + yath test --foo "xxx" + +You can also ask to have the environment variables cleared after they are checked: + + option foo => ( + prefix => 'blah', + type => 's', + env_vars => ['FOO', 'BAR'], + clear_env_vars => 1, # This tells yath to clear the env vars after they + are used. + ); + +If you would like the option set to the opposite of the envarinment variable +you can prefix it with a C<'!'> character: + + option foo =>( + ... + env_vars => ['!FOO'], + ); + +In this case these are equivelent: + + FOO=0 yath test + yath test --foo=1 + +Note that this only works when the variable is defined. If C<$ENV{FOO}> is not +defined then the variable is not used. + +=item $class->new(from_command => 'App::Yath::Command::COMMAND') + +=item $cmd_class = $opt->from_command() + +If your option was defined for a specific command this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(from_plugin => 'App::Yath::Plugin::PLUGIN') + +=item $plugin_class = $opt->from_plugin() + +If your option was defined for a specific plugin this will be set. You do not +normally set this yourself, the tools in L<App::Yath::Options> usually handle +that for you. + +=item $class->new(long_examples => [' foo', '=bar', ...]) + +=item $arrayref = $opt->long_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<--foo bar> would be wrong, you should just do C< bar>. + +=item $class->new(negate => sub { ... }) + +=item $coderef = $opt->negate() + +If you want a custom handler for negation C<--no-OPT> you can provide one here. + + option foo => ( + ... + negate => sub { + my ($prefix, $field, $slot, $settings, $options) = @_; + + ... + }, + ); + +The variables are the same as those in the C<action> callback. + +=item $class->new(normalize => sub { ... }) + +=item $coderef = $opt->normalize() + +The normalize attribute holds a callback sub that takes the raw value as input +and returns the normalized form. + + option foo => ( + ..., + normalize => sub { + my $raw = shift; + + ... + + return $norm; + }, + ); + +=item $class->new(pre_command => $bool) + +=item $bool = $opt->pre_command() + +Options are either command-specific, or pre-command. Pre-command options are +ones yath processes even if it has not determined what comamnd is being used. +Good examples are C<--dev-lib> and C<--plugin>. + + yath --pre-command-opt COMMAND --command-opt + +Most of the time this should be false, very few options qualify as pre-command. + +=item $class->new(pre_process => sub { ... }) + +=item $coderef = $opt->pre_process() + +This is essentially a BEGIN block for options. This callback is called as soon +as the option is parsed from the command line, well before the value is +normalized and added to settings. A good use for this is if your option needs +to inject additional L<App::Yath::Option> instances into the +L<App::Yath::Options> instance. + + option foo => ( + ... + + pre_process => sub { + my %params = @_; + + my $opt = $params{opt}; + my $options = $params{options}; + my $action = $params{action}; + my $type = $params{type}; + my $val = $params{val}; + + ...; + }, + ); + +Explanation of paremeters: + +=over 4 + +=item $params{opt} + +The op instance + +=item $params{options} + +The L<App::Yath::Options> instance. + +=item $params{action} + +A string, usually either "handle" or "handle_negation" + +=item $params{type} + +A string, usually C<"pre-command"> or C<"command ($CLASS)"> where the second +has the command package in the parentheses. + +=item $params{val} + +The value being set, if any. For options that do not take arguments, or in the +case of negation this key may not exist. + +=back + +=item $class->new(short => $single_character_string) + +=item $single_character_string = $opt->short() + +If you want your option to be usable as a short option (single character, +single dash C<-X>) then you can provide the character to use here. If the +option does not require an argument then it can be used along with other +no-argument short options: C<-xyz> would be equivilent to C<-x -y -z>. + +There are only so many single-characters available, so options are restricted +to picking only 1. + +B<Please note:> Yath reserves the right to add any single-character short +options in the main distribution, if they conflict with third party +plugins/commands then the third party must adapt and change its options. As +such it is not recommended to use any short options in third party addons. + +=item $class->new(short_examples => [' foo', ...]) + +=item $arrayref = $opt->short_examples() + +Used for documentation purposes. If your option takes arguments then you can +give examples here. The examples should not include the option itself, so +C<-f bar> would be wrong, you should just do C< bar>. + +This attribute is not used if you do not provide a C<short> attribute. + +=item $class->new(trace => [$package, $file, $line]) + +=item $arrayref = $opt->trace() + +This is almost always auto-populated for you via C<caller()>. It should be an +arrayref with a package, filename and line number. This is used if there is a +conflict between parameter names and/or short options. If such a situation +arises the file/line number of all conflicting options will be reported so it +can be fixed. + +=back + +=head1 METHODS + +=over 4 + +=item $bool = $opt->allows_arg() + +True if arguments can be provided to the option (based on type). This does not +mean the option MUST accept arguments. 'D' type options can accept arguments, +but can also be used without arguments. + +=item $bool = $opt->applicable($options) + +If an option provides an applicability callback this will use it to determine +if the option is applicable given the L<App::Yath::Options> instance. + +If no callback was provided then this returns true. + +=item $character = $opt->canon_type($type_name) + +Given a long alias for an option type this will return the single-character +canonical name. This will return undef for any unknown strings. This will not +translate single character names to themselves, so C<< $opt->canon_type('s') >> +will return undef while C<< $opt->canon_type('string') >> will return C<'s'>. + +=item $val = $opt->get_default() + +This will return the proper default value for the option. If a custom default +was provided it will be returned, otherwise the correct generic default for the +option type will be used. + +Here is a snippet showing the defaults for types: + + # First check env vars and return any values from there + ... + # Then check for a custom default and use it. + ... + + return 0 + if $self->{+TYPE} eq 'c' + || $self->{+TYPE} eq 'b'; + + return [] + if $self->{+TYPE} eq 'm' + || $self->{+TYPE} eq 'D'; + + return {} + if $self->{+TYPE} eq 'h' + || $self->{+TYPE} eq 'H'; + + # All others get undef + return undef; + +=item $val $opt->get_normalized($raw) + +This converts a raw value to a normalized one. If a custom C<normalize> +attribute was set then it will be used, otherwise it is normalized in +accordance to the type. + +This is where booleans are turned into 0 or 1, hashes are split, hash-lists are +split further, etc. + +=item $opt->handle($raw, $settings, $options, $list) + +This method handles setting the value in $settings. You should not normally +need to call this yourself. + +=item $opt->handle_negation() + +This method is used to handle a negated option. You should not normally need to +call this yourself. + +=item @list = $opt->long_args() + +Returns the name and any aliases. + +=item $ref = $opt->option_slot($settings) + +Get the settings->prefix->field reference. This creates the setting field if +necessary. + +=item $bool = $opt->requires_arg() + +Returns true if this option requires an argument when used. + +=item $string = $opt->trace_string() + +return a string like C<"somefile.pm line 42"> based on where the option was +defined. + +=item $bool = $opt->valid_type($character) + +Check if a single character type is valid. + +=back + +=head2 DOCUMENTATION GENERATION + +=over 4 + +=item $string = $opt->cli_docs() + +Get the option documentation in a format that works for the C<yath help +COMMAND> command. + +=item $string = $opt->pod_docs() + +Get the option documentation in POD format. + + =item .... + + .. option details ... + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options.pm b/liby/App/Yath/Options.pm new file mode 100644 index 000000000..42193254d --- /dev/null +++ b/liby/App/Yath/Options.pm @@ -0,0 +1,935 @@ +package App::Yath::Options; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Option(); +use Test2::Harness::Settings(); + +use Test2::Harness::Util::HashBase qw{ + <all <lookup + + <pre_list <cmd_list <post_list + + <post_list_sorted + + <settings + + <args + <command_class + + <pending_pre <pending_cmd <pending_post + + <used_plugins + + <included + + <set_by_cli +}; + +sub import { + my $class = shift; + my $caller = caller(); + + croak "$caller already has an 'options' method" + if defined(&{"$caller\::options"}); + + my @common; + my $instance; + my $options = sub { ($instance //= $class->new()) }; + my $option = sub { ($instance //= $class->new())->_option([caller()], shift(@_), @common ? (%{$common[-1]}) : (), @_) }; + my $include = sub { ($instance //= $class->new())->include_from(@_) }; + + my $post = sub { + my $cb = pop; + my $weight = shift // 0; + my ($applicable) = @_; + + $applicable //= $common[-1]->{applicable} if @common; + + croak "You must provide a callback coderef" unless $cb && ref($cb) eq 'CODE'; + + ($instance //= $class->new())->_post($weight, $applicable, $cb); + }; + + my $group = sub { + my ($set, $sub) = @_; + + my $common = {@common ? (%{$common[-1]}) : (), %$set}; + + if (my $class = $common->{builds}) { + require(mod2file($class)); + } + + push @common => $common; + my $ok = eval { $sub->(); 1 }; + my $err = $@; + pop @common; + + die $err unless $ok; + }; + + { + no strict 'refs'; + *{"$caller\::post"} = $post; + *{"$caller\::option"} = $option; + *{"$caller\::options"} = $options; + *{"$caller\::option_group"} = $group; + *{"$caller\::include_options"} = $include; + } + + return 1; +} + +sub init { + my $self = shift; + + $self->{+ALL} //= []; + $self->{+LOOKUP} //= {}; + + $self->{+USED_PLUGINS} //= []; + + $self->{+PRE_LIST} //= []; + $self->{+CMD_LIST} //= []; + $self->{+POST_LIST} //= []; + + $self->{+SETTINGS} //= Test2::Harness::Settings->new(); + + $self->{+INCLUDED} //= {}; + + $self->{+SET_BY_CLI} //= {}; + + return $self; +} + +sub option { + my $self = shift; + $self->_option([caller()], @_); +} + +sub include { + my $self = shift; + my ($inc) = @_; + + croak "Include must be an instance of ${ \__PACKAGE__ }, got ${ defined($inc) ? \qq['$inc'] : \'undef' }" + unless $inc && blessed($inc) && $inc->isa(__PACKAGE__); + + $self->include_option($_) for @{$inc->all}; + + $self->{+POST_LIST_SORTED} = 0; + push @{$self->{+POST_LIST}} => @{$inc->post_list}; + + return; +} + +sub include_from { + my $self = shift; + + for my $pkg (@_) { + require(mod2file($pkg)) unless $pkg->can('options'); + + next unless $pkg->can('options'); + my $options = $pkg->options or next; + $self->include($options); + + $self->{+INCLUDED}->{$pkg}++; + $self->{+INCLUDED}->{$_}++ for keys %{$options->included}; + } + + return; +} + +sub populate_pre_defaults { + my $self = shift; + + for my $opt (@{$self->_pre_command_options}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub populate_cmd_defaults { + my $self = shift; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + for my $opt (@{$self->_command_options()}) { + my $slot = $opt->option_slot($self->{+SETTINGS}); + my $val = $opt->get_default($self->{+SETTINGS}); + $$slot //= $val; + } +} + +sub grab_pre_command_opts { + my $self = shift; + my %config = @_; + + $self->populate_pre_defaults(); + + unshift @{$self->{+PENDING_PRE} //= []} => $self->_grab_opts( + '_pre_command_options', + 'pre-command', + stop_at_non_opt => 1, + passthrough => 1, + %config, + ); +} + +sub process_pre_command_opts { + my $self = shift; + return unless $self->{+PENDING_PRE}; + $self->_process_opts(delete $self->{+PENDING_PRE}); +} + +sub set_command_class { + my $self = shift; + my ($in) = @_; + + croak "Command class has already been set" + if $self->{+COMMAND_CLASS}; + + my $class = blessed($in) || $in; + + croak "Invalid command class: $class" + unless $class->isa('App::Yath::Command'); + + $self->include_from($class) if $class->can('options'); + + return $self->{+COMMAND_CLASS} = $class; +} + +sub set_args { + my $self = shift; + my ($in) = @_; + + croak "'args' has already been set" + if $self->{+ARGS}; + + return $self->{+ARGS} = $in; +} + +sub grab_command_opts { + my $self = shift; + my %config = @_; + + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + $self->populate_cmd_defaults(); + + push @{$self->{+PENDING_CMD} //= []} => $self->_grab_opts( + '_command_options', + "command (" . $self->{+COMMAND_CLASS}->name . ")", + %config, + ); +} + +sub process_command_opts { + my $self = shift; + return unless $self->{+PENDING_CMD}; + $self->_process_opts(delete $self->{+PENDING_CMD}); +} + +sub process_option_post_actions { + my $self = shift; + my ($cmd) = @_; + + croak "The 'args' attribute has not yet been set" + unless $self->{+ARGS}; + + if ($cmd) { + croak "The 'command_class' attribute has not yet been set" + unless $self->{+COMMAND_CLASS}; + + croak "The process_option_post_actions requires an App::Yath::Command instance, got: " . ($cmd // "undef") + unless blessed($cmd) && $cmd->isa('App::Yath::Command'); + + croak "The command '$cmd' dos not match the expected class '$self->{+COMMAND_CLASS}'" + unless blessed($cmd) eq $self->{+COMMAND_CLASS}; + } + + unless ($self->{+POST_LIST_SORTED}++) { + @{$self->{+POST_LIST}} = sort { $a->[0] <=> $b->[0] } @{$self->{+POST_LIST}}; + } + + for my $post (@{$self->{+POST_LIST}}) { + next if $post->[1] && !$post->[1]->($post->[2], $self); + $post->[2]->( + options => $self, + args => $self->{+ARGS}, + settings => $self->{+SETTINGS}, + $cmd ? (command => $cmd) : (), + ); + } +} + +sub _pre_command_options { $_[0]->{+PRE_LIST} } + +sub _command_options { + my $self = shift; + + my $class = $self->{+COMMAND_CLASS} or croak "The 'command_class' attribute has not yet been set"; + + my $cmd = $class->name; + my $cmd_options = $self->{+CMD_LIST} // []; + my $pre_options = $self->{+PRE_LIST} // []; + + return [grep { $_->applicable($self) } @$cmd_options, @$pre_options]; +} + +sub _process_opts { + my $self = shift; + my ($list) = @_; + + while (my $opt_set = shift @$list) { + my ($opt, $meth, @args) = @$opt_set; + $opt->$meth(@args, $self->{+SETTINGS}, $self, $list); + $self->{+SET_BY_CLI}->{$opt->prefix}->{$opt->field}++; + push @{$self->{+USED_PLUGINS}} => $opt->from_plugin if $opt->from_plugin; + } +} + +sub _parse_long_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^--((?:no-)?([^=]+))(=(.*))?$/ or confess "Invalid long option: $arg"; + + #return (main, full, val); + return ($2, $1, $3 ? $4 // '' : undef); +} + +sub _parse_short_option { + my $self = shift; + my ($arg) = @_; + + $arg =~ m/^-([^-])(=)?(.+)?$/ or confess "Invalid short option: $arg"; + + #return (main, remain, assign); + return ($1, $3, $2); +} + +sub _handle_long_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $full, $val) = $self->_parse_long_option($arg); + + my $opt; + if ($opt = $lookup->{long}->{$full}) { + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option --$full requires an argument.\n"; + } + elsif($opt->allows_arg) { + $val //= $opt->autofill // 1; + } + else { + die "Option --$full does not take an argument\n" if defined $val; + $val = 1; + } + + return [$opt, 'handle', $val]; + } + elsif ($opt = $lookup->{long}->{$main}) { + die "Option --$full does not take an argument\n" if defined $val; + return [$opt, 'handle_negation']; + } + + return undef; +} + +sub _handle_short_option { + my $self = shift; + my ($arg, $lookup, $args) = @_; + + my ($main, $remain, $assign) = $self->_parse_short_option($arg); + + if (my $opt = $lookup->{short}->{$main}) { + if ($opt->allows_arg) { + my $val = $remain; + + $val //= '' if $assign; + + if ($opt->requires_arg) { + $val //= shift(@$args) // die "Option -$main requires an argument.\n"; + } + else { + $val //= $opt->autofill // 1; + } + + $val //= 1; + return [$opt, 'handle', $val]; + } + elsif ($assign) { + die "Option -$main does not take an argument\n"; + } + elsif(defined($remain) && length($remain)) { + unshift @$args => "-$remain"; + } + + return [$opt, 'handle', 1]; + } + + return undef; +} + +my %ARG_ENDS = ('--' => 1, '::' => 1); + +sub _grab_opts { + my $self = shift; + my ($opt_fetch, $type, %config) = @_; + + croak "The opt_fetch callback is required" unless $opt_fetch; + croak "The arg type is required" unless $type; + + my $args = $config{args} || $self->{+ARGS} or confess "The 'args' attribute has not yet been set"; + + my $lookup = $self->_build_lookup($self->$opt_fetch()); + + my (@keep_args, @opts); + while (@$args) { + my $arg = shift @$args; + + if ($ARG_ENDS{$arg}) { + push @keep_args => $arg; + last; + } + + if (substr($arg, 0, 1) eq '-') { + my $handler = (substr($arg, 1, 1) eq '-') ? '_handle_long_option' : '_handle_short_option'; + if(my $opt_set = $self->$handler($arg, $lookup, $args)) { + my ($opt, $action, @val) = @$opt_set; + + if (my $pre = $opt->pre_process) { + $pre->( + opt => $opt, + options => $self, + action => $action, + type => $type, + + @val ? (val => $val[0]) : (), + ); + } + + $lookup = $self->_build_lookup($self->$opt_fetch()) + if $opt->adds_options; + + push @opts => $opt_set; + next; + } + elsif (!$config{passthrough}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + } + + if ($config{die_at_non_opt}) { + my $err = "Invalid $type option: $arg"; + my $handled = $self->{+COMMAND_CLASS} && $self->{+COMMAND_CLASS}->handle_invalid_option($type, $arg, $err); + die "$err\n" unless $handled; + } + + push @keep_args => $arg; + + last if $config{stop_at_non_opt}; + } + + unshift @$args => @keep_args; + + return @opts; +} + +sub _build_lookup { + my $self = shift; + my ($opts) = @_; + + my $lookup = {long => {}, short => {}}; + + my %seen; + for my $opt (@$opts) { + next if $seen{$opt}++; + + for my $long ($opt->long_args) { + $lookup->{long}->{$long} //= $opt; + } + + my $short = $opt->short or next; + $lookup->{short}->{$short} //= $opt; + } + + return $lookup; +} + +sub _post { + my $self = shift; + my ($weight, $applicable, $cb) = @_; + + $self->{+POST_LIST_SORTED} = 0; + + $weight //= 0; + + push @{$self->{+POST_LIST} //= []} => [$weight, $applicable, $cb]; +} + +sub _option { + my $self = shift; + my ($trace, @spec) = @_; + + my %proto = $self->_parse_option_args(@spec); + + my $opt = App::Yath::Option->new( + trace => $trace, + $self->_parse_option_caller($trace->[0], \%proto), + %proto, + ); + + $self->include_option($opt); +} + +sub include_option { + my $self = shift; + my ($opt) = @_; + + my $trace = $opt->trace or confess "Options must have a trace!"; + + push @{$self->{+ALL}} => $opt; + + my $new = $self->_index_option($opt); + $self->_list_option($opt) if $new; + + return $opt; +} + +sub _parse_option_caller { + my $self = shift; + my ($caller, $proto) = @_; + + my ($from_plugin, $from_command, $from_prefix, $prefix, $is_top); + + $prefix = $proto->{prefix} if exists $proto->{prefix}; + $prefix //= $caller->option_prefix() if $caller->can('option_prefix'); + + if ($caller->isa('App::Yath::Command')) { + $from_command = $caller->name() unless $caller eq 'App::Yath::Command'; + $is_top = 1; + } + elsif ($caller =~ m/App::Yath::Command::([^:]+)::.*Options(?:::.*)?$/) { + $from_command = $1; + $is_top = 1; + } + elsif ($caller eq 'App::Yath') { + $is_top = 1; + } + elsif ($caller =~ m/^(App::Yath::Plugin::([^:]+))$/) { + $from_plugin = $1; + $from_prefix = $2; + + unless (defined $prefix) { + $prefix = $from_prefix; + $prefix =~ s/::.*$//g; + } + } + + $prefix = lc($prefix) if $prefix; + + croak "Could not find an option prefix and option is not top-level ($proto->{title})" + unless $is_top || defined($prefix) || defined($proto->{prefix}); + + return ( + $from_plugin ? (from_plugin => $from_plugin) : (), + $from_command ? (from_command => $from_command) : (), + ($prefix || !$is_top) ? (prefix => $prefix) : (), + ); +} + +sub _parse_option_args { + my $self = shift; + my @spec = @_; + + my %args; + if (@spec == 1) { + my ($title, $type) = $spec[0] =~ m/^([\w-]+)(?:=(.+))?$/ or croak "Invalid option specification: $spec[0]"; + return (title => $title, type => $type); + } + elsif (@spec == 2) { + my ($title, $type) = @spec; + return (title => $title, type => $type); + } + + my $title = shift @spec; + return (title => $title, @spec); +} + +sub _index_option { + my $self = shift; + my ($opt) = @_; + + my $index = $self->{+LOOKUP}; + + my $out = 0; + + for my $n ($opt->name, @{$opt->alt || []}) { + if (my $existing = $index->{$n}) { + next if "$existing" eq "$opt"; + croak "Option '$n' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$n} = $opt; + } + + if (my $short = $opt->short) { + if (my $existing = $index->{$short}) { + return $out if "$existing" eq "$opt"; + croak "Option '$short' was already defined (" . $existing->trace_string . ")"; + } + + $out++; + $index->{$short} = $opt; + } + + return $out; +} + +sub _list_option { + my $self = shift; + my ($opt) = @_; + + return push @{$self->{+PRE_LIST}} => $opt + if $opt->pre_command; + + push @{$self->{+CMD_LIST}} => $opt; +} + +sub pre_docs { + my $self = shift; + + return $self->_docs($self->_pre_command_options(), @_); +} + +sub cmd_docs { + my $self = shift; + + return unless $self->{+COMMAND_CLASS}; + + return $self->_docs([grep { !$_->pre_command } @{$self->_command_options()}], @_); +} + +my %DOC_FORMATS = ( + 'cli' => [ + 'cli_docs', # Method to call on opt + "\n", # how to join lines + sub { "\n$_[1]" }, # how to render the category + sub { $_[0] =~ s/^/ /mg; "$_[0]\n" }, # transform the value from the opt + sub { }, # add this at the end + ], + 'pod' => [ + 'pod_docs', # Method to call on opt + "\n\n", # how to join lines + sub { ($_[0] ? ("=back") : (), "=head$_[2] $_[1]", "=over 4") }, # how to render the category + sub { $_[0] }, # transform the value from the opt + sub { $_[0] ? ("=back") : () }, # add this at the end + ], +); + +sub _docs { + my $self = shift; + my ($opts, $format, @args) = @_; + + $format //= "UNDEFINED"; + my $fset = $DOC_FORMATS{$format} or croak "Invalid documentation format '$format'"; + my ($fmeth, $join, $fcat, $ftrans, $fend) = @$fset; + + return unless $opts; + return unless @$opts; + + my @opts = sort _doc_sort_ops @$opts; + + my @out; + + my $cat; + for my $opt (@opts) { + if (!$cat || $opt->category ne $cat) { + push @out => $fcat->($cat, $opt->category, @args); + $cat = $opt->category; + } + + my $help = $opt->$fmeth(); + push @out => $ftrans->($help); + } + + push @out => $fend->($cat); + + return join $join => @out; +} + +sub _doc_sort_ops($$) { + my ($a, $b) = @_; + + my $anc = $a->category eq 'NO CATEGORY - FIX ME'; + my $bnc = $b->category eq 'NO CATEGORY - FIX ME'; + + if($anc xor $bnc) { + return 1 if $anc; + return -1; + } + + my $ret = $a->category cmp $b->category; + $ret ||= ($a->prefix || '') cmp ($b->prefix || ''); + $ret ||= $a->field cmp $b->field; + $ret ||= $a->name cmp $b->name; + + return $ret; +} + +sub clear_env { + my $self = shift; + + for my $opt (@{$self->{+ALL}}) { + next unless $opt->clear_env_vars; + my $env = $opt->env_vars or next; + for my $var (@$env) { + $var =~ s/^!//; + delete $ENV{$var}; + } + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options - Tools for defining and tracking yath CLI options. + +=head1 DESCRIPTION + +This class represents a collection of options, and holds the logic for +processing them. This package also exports sugar to help you define options. + +=head1 SYNOPSIS + + package My::Options; + + use App::Yath::Options; + + # This package now has a package instance of options, which can be obtained + # via the options() method. + my $options = __PACKAGE__->options; + + # We can include options from other packages + include_options( + 'Package::With::Options::A', + 'Package::With::Options::B', + ..., + ); + + # Define an option group with some options + option_group { %common_fields } => sub { + + # Define an option + option foo => ( + type => 's', + default => "FOOOOOOO", + category => 'foo', + description => "This is foo" + long_examples => [' value'], + ... + ); + + option bar => ( ... ); + ... + }; + + # Action to call right after options are parsed. + post sub { + my %params = @_; + + ... + }; + +=head1 EXPORTS + +=over 4 + +=item $opts = options() + +=item $opts = $class->options() + +This returns the options instance associated with your package. + +=item include_options(@CLASSES) + +This lets you include options defined in other packages. + +=item option_group \%COMMON_FIELDS => sub { ... } + +An option group is simply a block where all calls to C<option()> will have +common fields added automatically, this makes it easier to define multiple +options that share common fields. Common fields can be overridden inside the +option definition. + +These are both equivalent: + + # Using option group + option_group { category => 'foo', prefix => 'foo' } => sub { + option a => (type => 'b'); + option b => (type => 's'); + }; + + # Not using option group + option a => (type => 'b', category => 'foo', prefix => 'foo'); + option b => (type => 's', category => 'foo', prefix => 'foo'); + +=item option TITLE => %FIELDS + +Define an option. The first argument is the C<title> attribute for the new +option, all other arguments should be attribute/value pairs used to construct +the option. See L<App::Yath::Option> for the documentation of attributes. + +=item post sub { ... } + +=item post $weight => sub { ... } + +C<post> callbacks are run after all command line arguments have been processed. +This is a place to verify the result of several options combined, sanity check, +or even add short-circuit behavior. This is how the C<--help> and +C<--show-opts> options are implemented. + +If no C<$weight> is specified then C<0> is used. C<post> callbacks or sorted +based on weight with higher values being run later. + +=back + +=head1 OPTIONS INSTANCES + +In general you should not be using the options instance directly. Options +instances are mostly an implementation detail that should be treated as a black +box. There are however a few valid reasons to interact with them directly. In +those cases there are a few public attributes/methods you can work with. This +section documents the public interface. + +=head2 ATTRIBUTES + +This section only lists attributes that may be useful to people working with +options instances. There are a lot of internal (to yath) attributes that are +implementation details that are not listed here. Attributes not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $arrayref = $options->all + +Arrayref containing all the L<App::Yath::Option> instances in the options +instance. + +=item $settings = $options->settings + +Get the L<Test2::Harness::Settings> instance. + +=item $arrayref = $options->args + +Get the reference to the list of command line arguments. This list is modified +as arguments are processed, there are no guarentees about what is in here at +any given stage of argument processing. + +=item $class_name = $options->command_class + +If yath has determined what command is being executed this will be populated +with that command class. This will be undefined if the class has not been +determined yet. + +=item $arrayref = $options->used_plugins + +This is a list of all plugins who's options have been used. Plugins may appear +more than once. + +=item $hashref = $options->included + +A hashref where every key is a package who's options have been included into +this options instance. The values are an implementation detail, do not rely on +them. + +=back + +=head2 METHODS + +This section only lists methods that may be useful to people working with +options instances. There are a lot of internal (to yath) methods that are +implementation details that are not listed here. Methods not listed here are +not intended for external use and may change at any time. + +=over 4 + +=item $opt = $options->option(%OPTION_ATTRIBUTES) + +This will create a new option with the provided attributes and add it to the +options instance. A C<trace> attribute will be automatically set for you. + +=item $options->include($options_instance) + +This method lets you directly include options from a second instance into the +first. + +=item $options->include_from(@CLASSES) + +This lets you include options from multiple classes that have options defined. + +=item $options->include_option($opt) + +This lets you include a single already defined option instance. + +=item $options->pre_docs($format, @args) + +Get documentation for pre-command options. $format may be 'cli' or 'pod'. + +=item $options->cmd_docs($format, @args) + +Get documentation for command options. $format may be 'cli' or 'pod'. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Collector.pm b/liby/App/Yath/Options/Collector.pm new file mode 100644 index 000000000..e60ed5d85 --- /dev/null +++ b/liby/App/Yath/Options/Collector.pm @@ -0,0 +1,89 @@ +package App::Yath::Options::Collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Options; + +option_group {prefix => 'collector', category => "Collector Options"} => sub { + option max_open_jobs => ( + type => 's', + description => 'Maximum number of jobs a collector can process at a time, if more jobs are pending their output will be delayed until the earlier jobs have been processed. (Default: double the -j value)', + long_examples => [' 18'], + short_examples => [' 18'], + ); + + option max_poll_events => ( + type => 's', + description => 'Maximum number of events to poll from a job before jumping to the next job. (Default: 1000)', + default => 1000, + long_examples => [' 1000'], + short_examples => [' 1000'], + ); + + post \&collector_post; +}; + +sub collector_post { + my %params = @_; + my $settings = $params{settings}; + + unless ($settings->collector->max_open_jobs) { + my $j = $settings->runner->job_count // 1; + my $max_open = 2 * $j; + $settings->collector->field(max_open_jobs => $max_open); + } +} + + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Collector - collector options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the collector are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Debug.pm b/liby/App/Yath/Options/Debug.pm new file mode 100644 index 000000000..d728d48bc --- /dev/null +++ b/liby/App/Yath/Options/Debug.pm @@ -0,0 +1,338 @@ +package App::Yath::Options::Debug; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::JSON qw/encode_pretty_json/; +use Test2::Util::Table qw/table/; +use Test2::Harness::Util qw/find_libraries mod2file clean_path/; + +use Errno qw/EINTR/; + +use App::Yath::Options; + +option_group {prefix => 'debug', category => 'Help and Debugging'} => sub { + post 99999 => \&_post_process_show_opts; + post 99998 => \&_post_process_interactive; + post \&_post_process_version; + post \&_post_process_help; + + option dummy => ( + short => 'd', + description => 'Dummy run, do not actually execute anything', + env_vars => [qw/T2_HARNESS_DUMMY/], + clear_env_vars => 1, + default => 0, + ); + + option procname_prefix => ( + type => 's', + default => '', + description => 'Add a prefix to all proc names (as seen by ps).', + ); + + option keep_dirs => ( + short => 'k', + alt => ['keep_dir'], + description => 'Do not delete directories when done. This is useful if you want to inspect the directories used for various commands.', + default => 0, + ); + + option 'show-opts' => ( + description => 'Exit after showing what yath thinks your options mean', + pre_command => 1, + ); + + option version => ( + short => 'V', + description => "Exit after showing a helpful usage message", + pre_command => 1, + ); + + option help => ( + short => 'h', + description => "exit after showing help information", + ); + + option interactive => ( + short => 'i', + description => 'Use interactive mode, 1 test at a time, stdin forwarded to it', + ); + + option summary => ( + type => 'd', + description => "Write out a summary json file, if no path is provided 'summary.json' will be used. The .json extension is added automatically if omitted.", + + long_examples => ['', '=/path/to/summary.json'], + + normalize => \&normalize_summary, + action => \&summary_action, + applicable => sub { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; + }, + ); +}; + +sub normalize_summary { + my $val = shift; + + return $val if $val eq '1'; + + $val =~ s/\.json$//g; + $val .= '.json'; + + return clean_path($val); +} + +sub summary_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path($norm) + unless $norm eq '1'; + + return if $$slot; + return $$slot = clean_path('summary.json'); +} + +sub _post_process_help { + my %params = @_; + + return unless $params{settings}->debug->help; + + my $help; + if (my $cmd = $params{command}) { + $help = $cmd->cli_help(%params); + } + else { + $help = __PACKAGE__->cli_help(%params); + } + + if (eval { require IO::Pager; 1 }) { + local $SIG{PIPE} = sub {}; + my $pager = IO::Pager->new(*STDOUT); + $pager->print($help); + } + else { + print $help; + } + + exit 0; +} + +sub _post_process_show_opts { + my %params = @_; + + return unless $params{settings}->debug->show_opts; + + my $settings = $params{settings}; + + print "\nCommand selected: " . $params{command}->name . " (" . ref($params{command}) . ")\n" if $params{command}; + + my $args = $params{args}; + print "\nCommand args: " . join(', ' => @$args) . "\n" if @$args; + + my $out = encode_pretty_json($settings); + + print "\nCurrent command line and config options result in these settings:\n"; + print "$out\n"; + + exit 0; +} + +my $RAN = 0; +sub _post_process_interactive { + return if $RAN++; + my %params = @_; + + return unless $params{settings}->debug->interactive; + + my $settings = $params{settings}; + + my ($fifo); + if ($settings->check_prefix('workspace')) { + my $dir = $settings->workspace->workdir; + $fifo = "$dir/fifo-$$"; + } + else { + require File::Temp; + my $fh; + ($fh, $fifo) = File::Temp::tempfile("YATH-FIFO-$$-XXXXXX", TMPDIR => 1); + close($fh); + unlink($fifo); + } + + ${$settings->debug->vivify_field('fifo')} = $fifo; + + if ($settings->check_prefix('display')) { + $settings->display->field(quiet => 0); + $settings->display->field(verbose => 1) unless $settings->display->verbose; + } + + if ($settings->check_prefix('formatter')) { + $settings->formatter->field(qvf => 0); + } + + if ($settings->check_prefix('run')) { + $settings->run->env_vars->{YATH_INTERACTIVE} = $fifo; + $ENV{YATH_INTERACTIVE} = $fifo; + } + + my $pid = fork() // die "Could not fork: $!"; + if ($pid) { + require Scope::Guard; + require POSIX; + POSIX::mkfifo($fifo, 0700) or die "Failed to make fifo ($fifo): $!"; + my $fh; + + my $cleanup = sub { + close($fh) if $fh; + unlink($fifo) if -e $fifo; + }; + + my $old_int_handler = $SIG{INT}; + my $old_term_handler = $SIG{TERM}; + + $SIG{INT} = sub { $cleanup->('INT'); $old_int_handler->() if ref $old_int_handler; exit 1; }; + $SIG{TERM} = sub { $cleanup->('TERM'); $old_term_handler->() if ref $old_term_handler; exit 1; }; + $SIG{PIPE} = sub { exit 1 }; + + $SIG{CHLD} = sub { + my $res = waitpid($pid, 0); + my $exit = ($? >> 8); + + close($fh) if $fh; + unlink($fifo) if -e $fifo; + + # Forward the exit code from our child + exit($exit); + }; + + for (1 .. 10) { + last if open($fh, '>', $fifo); + die "Could not open fifo ($fifo): $!" unless $! == EINTR; + sleep 1; + } + die "Could not open fifo ($fifo): $!" unless $fh; + + $fh->autoflush(1); + my $guard = Scope::Guard->new($cleanup); + + while(1) { + my $data = <STDIN>; + if (defined($data) && length($data)) { + print $fh $data; + next; + } + + next if defined($data); + + next if kill(0, $pid); + print STDERR "Lost child process $pid\n"; + $cleanup->(); + exit 255; + } + } + + close(STDIN); + open(STDIN, '<', '/dev/null'); + + require Time::HiRes; + while (! -e $fifo) { Time::HiRes::sleep(0.1) }; +} + +sub _post_process_version { + my %params = @_; + + return unless $params{settings}->debug->version; + + require App::Yath; + my $out = <<" EOT"; + +Yath version: $App::Yath::VERSION + +Extended Version Info + EOT + + my $plugin_libs = find_libraries('App::Yath::Plugin::*'); + + my @vers = ( + [perl => $^V], + ['App::Yath' => App::Yath->VERSION], + ( + map { + eval { require(mod2file($_)); 1 } + ? [$_ => $_->VERSION // 'N/A'] + : [$_ => 'N/A'] + } qw/Test2::API Test2::Suite Test::Builder/ + ), + ( + map { + eval { require($plugin_libs->{$_}); 1 } + && [$_ => $_->VERSION // 'N/A'] + } sort keys %$plugin_libs + ), + ); + + $out .= join "\n" => table( + header => [qw/COMPONENT VERSION/], + rows => \@vers, + ); + + print "$out\n\n"; + + exit 0; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Debug - Debug options for Yath + +=head1 DESCRIPTION + +This is where debug related command line options live. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Display.pm b/liby/App/Yath/Options/Display.pm new file mode 100644 index 000000000..0deaf119f --- /dev/null +++ b/liby/App/Yath/Options/Display.pm @@ -0,0 +1,237 @@ +package App::Yath::Options::Display; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +option_group {prefix => 'display', category => "Display Options"} => sub { + option color => ( + description => "Turn color on, default is true if STDOUT is a TTY.", + default => sub { -t STDOUT ? 1 : 0 }, + ); + + option quiet => ( + short => 'q', + type => 'c', + description => "Be very quiet.", + default => 0, + ); + + option verbose => ( + short => 'v', + type => 'c', + description => "Be more verbose", + default => 0, + ); + + option no_wrap => ( + type => 'b', + description => "Do not do fancy text-wrapping, let the terminal handle it", + default => 0, + ); + + option show_times => ( + short => 'T', + description => 'Show the timing data for each job', + ); + + option hide_runner_output => ( + description => 'Hide output from the runner, showing only test output. (See Also truncate_runner_output)', + default => 0, + ); + + option truncate_runner_output => ( + description => 'Only show runner output that was generated after the current command. This is only useful with a persistent runner.', + default => 0, + ); + + option term_width => ( + type => 's', + alt => ['term-size'], + description => 'Alternative to setting $TABLE_TERM_SIZE. Setting this will override the terminal width detection to the number of characters specified.', + long_examples => [' 80', ' 200'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + $ENV{TABLE_TERM_SIZE} = $norm; + }, + ); + + option 'progress' => ( + default => sub { -t STDOUT ? 1 : 0 }, + + description => "Toggle progress indicators. On by default if STDOUT is a TTY. You can use --no-progress to disable the 'events seen' counter and buffered event pre-display", + ); + + option renderers => ( + alt => ['renderer'], + type => 'H', + + description => 'Specify renderers, (Default: "Formatter=Test2"). Use "+" to give a fully qualified module name. Without "+" "Test2::Harness::Renderer::" will be prepended to your argument.', + + long_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + short_examples => [' +My::Renderer', ' Renderer=arg1,arg2,...'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($class, $args) = @$norm; + + $class = "Test2::Harness::Renderer::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + my $ok = eval { require $file; 1 }; + warn "Failed to load renderer '$class': $@" unless $ok; + + $handler->($slot, [$class, $args]); + }, + ); + + post 100 => sub { + my %params = @_; + my $settings = $params{settings}; + + my $display = $settings->display; + my $renderers = $display->renderers; + + my $quiet = $display->quiet; + my $verbose = $display->verbose; + + die "The 'quiet' and 'verbose' options may not be used together.\n" + if $verbose && $quiet; + + if ($quiet) { + delete $renderers->{'Test2::Harness::Renderer::Formatter'}; + @{$renderers->{'@'}} = grep { $_ ne 'Test2::Harness::Renderer::Formatter' } @{$renderers->{'@'}}; + return; + } + + my @args = map { $_ => $settings->formatter->$_ } qw{ + formatter + show_run_info + show_job_info + show_job_launch + show_job_end + }; + + push @args => map { $_ => $settings->display->$_ } qw{ + progress + color + quiet + verbose + show_times + }; + + if (my $formatter_args = $renderers->{'Test2::Harness::Renderer::Formatter'}) { + @$formatter_args = @args unless @$formatter_args; + return; + } + + return if $renderers->{'@'} && @{$renderers->{'@'}}; + + push @{$renderers->{'@'}} => 'Test2::Harness::Renderer::Formatter'; + $renderers->{'Test2::Harness::Renderer::Formatter'} = \@args; + }; +}; + +option_group {prefix => 'formatter', category => "Formatter Options"} => sub { + option formatter => ( + type => 's', + ); + + option 'qvf' => ( + description => '[Q]uiet, but [V]erbose on [F]ailure. Hide all output from tests when they pass, except to say they passed. If a test fails then ALL output from the test is verbosely output.', + ); + + option show_job_end => ( + description => 'Show output when a job ends. (Default: on)', + default => 1, + ); + + option show_job_info => ( + description => 'Show the job configuration when a job starts. (Default: off, unless -vv)', + default => 0, + ); + + option show_job_launch => ( + description => "Show output for the start of a job. (Default: off unless -v)", + default => 0, + ); + + option show_run_info => ( + description => 'Show the run configuration when a run starts. (Default: off, unless -vv)', + default => 0, + ); + + post 90 => sub { + my %params = @_; + my $settings = $params{settings}; + + $settings->formatter->field(formatter => $settings->formatter->qvf ? 'QVF' : 'Test2') + unless defined $settings->formatter->formatter; + + $settings->formatter->field(show_job_launch => 1) + if $settings->display->verbose > 0; + + if ($settings->display->verbose > 1) { + $settings->formatter->field(show_job_info => 1); + $settings->formatter->field(show_run_info => 1); + } + }; +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Display - Display options for Yath. + +=head1 DESCRIPTION + +This is where display options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Finder.pm b/liby/App/Yath/Options/Finder.pm new file mode 100644 index 000000000..58557d346 --- /dev/null +++ b/liby/App/Yath/Options/Finder.pm @@ -0,0 +1,391 @@ +package App::Yath::Options::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/mod2file/; + +use App::Yath::Options; + +my %RERUN_MODES = ( + all => "Re-Run all tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + failed => "Re-Run failed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + retried => "Re-Run retried tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + passed => "Re-Run passed tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + missed => "Run missed tests from a previously aborted/stopped run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", +); + +option_group {prefix => 'finder', category => "Finder Options", builds => 'Test2::Harness::Finder'} => sub { + option finder => ( + type => 's', + default => 'Test2::Harness::Finder', + description => 'Specify what Finder subclass to use when searching for files/processing the file list. Use the "+" prefix to specify a fully qualified namespace, otherwise Test2::Harness::Finder::XXX namespace is assumed.', + long_examples => [' MyFinder', ' +Test2::Harness::Finder::MyFinder'], + pre_command => 1, + adds_options => 1, + pre_process => \&finder_pre_process, + action => \&finder_action, + + builds => undef, # This option is not for the build + ); + + option extension => ( + field => 'extensions', + type => 'm', + alt => ['ext'], + description => 'Specify valid test filename extensions, default: t and t2', + ); + + option search => ( + type => 'm', + + description => 'List of tests and test directories to use instead of the default search paths. Typically these can simply be listed as command line arguments without the --search prefix.', + ); + + option no_long => ( + description => "Do not run tests that have their duration flag set to 'LONG'", + ); + + option only_long => ( + description => "Only run tests that have their duration flag set to 'LONG'", + ); + + option show_changed_files => ( + description => "Print a list of changed files if any are found", + applicable => \&changes_applicable, + ); + + option changed_only => ( + description => "Only search for tests for changed files (Requires a coverage data source, also requires a list of changes either from the --changed option, or a plugin that implements changed_files() or changed_diff())", + applicable => \&changes_applicable, + ); + + option rerun => ( + type => 'd', + description => "Re-Run tests from a previous run from a log file (or last log file). Plugins can intercept this, such as YathUIDB which will grab a run UUID and derive tests to re-run from that.", + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ); + + option rerun_plugin => ( + type => 'm', + description => "What plugin(s) should be used for rerun (will fallback to other plugins if the listed ones decline the value, this is just used ot set an order of priority)", + long_examples => [' Foo', ' +App::Yath::Plugin::Foo'], + ); + + option rerun_modes => ( + alt => ['rerun-mode'], + type => 'm', + description => "Pick which test categories to run", + long_examples => [' failed,missed,...', map {" $_"} sort keys %RERUN_MODES], + ); + + for my $mode (keys %RERUN_MODES) { + option "rerun_$mode" => ( + type => 'd', + description => $RERUN_MODES{$mode}, + long_examples => ['', '=path/to/log.jsonl', '=plugin_specific_string'], + ignore_for_build => 1, + ); + } + + option changed => ( + type => 'm', + description => "Specify one or more files as having been changed.", + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_file => ( + type => 'm', + description => 'Specify one or more files to ignore when looking at changes', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_exclude_pattern => ( + type => 'm', + description => 'Ignore files matching this pattern when looking for changes. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_filter_file => ( + type => 'm', + description => 'Specify one or more files to check for changes. Changes to other files will be ignored', + long_examples => [' path/to/file'], + applicable => \&changes_applicable, + ); + + option changes_filter_pattern => ( + type => 'm', + description => 'Specify a pattern for change checking. When only running tests for changed files this will limit which files are checked for changes. Only files that match this pattern will be checked. Your pattern will be inserted unmodified into a `$file =~ m/$pattern/` check.', + long_examples => [" '(apple|pear|orange)'"], + applicable => \&changes_applicable, + ); + + option changes_diff => ( + type => 's', + description => "Path to a diff file that should be used to find changed files for use with --changed-only. This must be in the same format as `git diff -W --minimal -U1000000`", + long_examples => [' path/to/diff.diff'], + applicable => \&changes_applicable, + ); + + option changes_plugin => ( + type => 's', + description => "What plugin should be used to detect changed files.", + long_examples => [' Git', ' +App::Yath::Plugin::Git'], + applicable => \&changes_applicable, + ); + + option changes_include_whitespace => ( + type => 'b', + description => "Include changed lines that are whitespace only (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_nonsub => ( + type => 'b', + description => "Exclude changes outside of subroutines (perl files only) (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_loads => ( + type => 'b', + description => "Exclude coverage tests which only load changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option changes_exclude_opens => ( + type => 'b', + description => "Exclude coverage tests which only open() changed files, but never call code from them. (default: off)", + applicable => \&changes_applicable, + default => 0, + ); + + option durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option maybe_durations => ( + type => 's', + + long_examples => [' file.json', ' http://example.com/durations.json'], + short_examples => [' file.json', ' http://example.com/durations.json'], + + description => "Point at a json file or url which has a hash of relative test filenames as keys, and 'SHORT', 'MEDIUM', or 'LONG' as values. This will override durations listed in the file headers. An exception will be thrown if the durations file or url does not work.", + ); + + option durations_threshold => ( + alt => ['Dt'], + type => 's', + default => undef, + description => "Only fetch duration data if running at least this number of tests. Default (-j value + 1)" + ); + + option exclude_file => ( + field => 'exclude_files', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a file from testing", + ); + + option exclude_pattern => ( + field => 'exclude_patterns', + type => 'm', + + long_examples => [' t/nope.t'], + short_examples => [' t/nope.t'], + + description => "Exclude a pattern from testing, matched using m/\$PATTERN/", + ); + + option exclude_list => ( + field => 'exclude_lists', + type => 'm', + + long_examples => [' file.txt', ' http://example.com/exclusions.txt'], + short_examples => [' file.txt', ' http://example.com/exclusions.txt'], + + description => "Point at a file or url which has a new line separated list of test file names to exclude from testing. Starting a line with a '#' will comment it out (for compatibility with Test2::Aggregate list files).", + ); + + option default_search => ( + type => 'm', + + description => "Specify the default file/dir search. defaults to './t', './t2', and 'test.pl'. The default search is only used if no files were specified at the command line", + ); + + option default_at_search => ( + type => 'm', + + description => "Specify the default file/dir search when 'AUTHOR_TESTING' is set. Defaults to './xt'. The default AT search is only used if no files were specified at the command line", + ); + + post \&_post_process; +}; + +sub _post_process { + my %params = @_; + my $settings = $params{settings}; + my $options = $params{options}; + + my $finder = $settings->finder; + + my $rerun = $finder->rerun; + + for my $mode (sort keys %RERUN_MODES) { + my $val = $finder->remove_field("rerun_$mode") or next; + + push @{$finder->rerun_modes} => $mode; + + next if $val eq '1'; + + $rerun //= $val; + $rerun = $val if $rerun eq '1'; + + die "Multiple runs specified for rerun ($val and $rerun). Please pick one.\n" if $val ne $rerun; + } + + $finder->field(rerun => $rerun); + + my (%seen, @keep); + for my $mode (sort map { split /,/ } @{$finder->rerun_modes}) { + next if $seen{$mode}++; + die "Invalid rerun-mode '$mode'.\n" unless $RERUN_MODES{$mode}; + push @keep => $mode; + } + push @keep => 'all' unless @keep; + + @{$finder->rerun_modes} = @keep; + + if (!defined($settings->finder->durations_threshold)) { + if ($settings->check_prefix('runner')) { + my $jc = $settings->runner->job_count // 1; + $settings->finder->field(durations_threshold => $jc + 1); + } + + $settings->finder->field(durations_threshold => 1); + } + + $settings->finder->field(default_search => ['./t', './t2', 'test.pl']) + unless $settings->finder->default_search && @{$settings->finder->default_search}; + + $settings->finder->field(default_at_search => ['./xt']) + unless $settings->finder->default_at_search && @{$settings->finder->default_at_search}; + + @{$settings->finder->extensions} = ('t', 't2') + unless @{$settings->finder->extensions}; + + s/^\.//g for @{$settings->finder->extensions}; +} + +sub normalize_class { + my ($class) = @_; + + $class = "Test2::Harness::Finder::$class" + unless $class =~ s/^\+//; + + my $file = mod2file($class); + require $file; + + return $class; +} + +sub finder_pre_process { + my %params = @_; + + my $class = $params{val} or return; + + $class = normalize_class($class); + + return unless $class->can('options'); + + $params{options}->include_from($class); +} + +sub finder_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my $class = $norm; + + $class = normalize_class($class); + + if ($class->can('options')) { + $options->populate_pre_defaults(); + $options->populate_cmd_defaults(); + } + + $class->munge_settings($settings, $options) if $class->can('munge_settings'); + + $handler->($slot, $class); +} + +sub changes_applicable { + my ($option, $options) = @_; + + # Cannot use this options with projects + return 0 if $options->command_class && $options->command_class->isa('App::Yath::Command::projects'); + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Finder - Finder options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for discovering test files are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Logging.pm b/liby/App/Yath/Options/Logging.pm new file mode 100644 index 000000000..377ea2012 --- /dev/null +++ b/liby/App/Yath/Options/Logging.pm @@ -0,0 +1,169 @@ +package App::Yath::Options::Logging; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX qw/strftime/; +use Test2::Harness::Util qw/clean_path/; +use File::Spec; + +use App::Yath::Options; + +option_group {prefix => 'logging', category => "Logging Options"} => sub { + option log => ( + short => 'L', + description => 'Turn on logging', + ); + + option log_file_format => ( + alt => ['lff'], + type => 's', + + env_vars => [qw/YATH_LOG_FILE_FORMAT TEST2_HARNESS_LOG_FORMAT/], + default => sub { '%!P%Y-%m-%d_%H:%M:%S_%!U.jsonl' }, + + description => 'Specify the format for automatically-generated log files. Overridden by --log-file, if given. This option implies -L (Default: \$YATH_LOG_FILE_FORMAT, if that is set, or else "%!P%Y-%m-%d~%H:%M:%S~%!U~%!p.jsonl"). This is a string in which percent-escape sequences will be replaced as per POSIX::strftime. The following special escape sequences are also replaced: (%!P : Project name followed by a ~, if a project is defined, otherwise empty string) (%!U : the unique test run ID) (%!p : the process ID) (%!S : the number of seconds since local midnight UTC)', + + ); + + option bzip2 => ( + short => 'B', + alt => ['bz2', 'bzip2_log'], + description => 'Use bzip2 compression when writing the log. This option implies -L. The .bz2 prefix is added to log file name for you', + ); + + option gzip => ( + short => 'G', + alt => ['gz', 'gzip_log'], + description => 'Use gzip compression when writing the log. This option implies -L. The .gz prefix is added to log file name for you', + ); + + option log_dir => ( + type => 's', + normalize => \&clean_path, + description => 'Specify a log directory. Will fall back to the system temp dir.', + ); + + option log_file => ( + short => 'F', + type => 's', + normalize => \&clean_path, + description => "Specify the name of the log file. This option implies -L.", + ); + + post \&post_process; +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + my $logging = $settings->logging; + + die "You cannot specify both bzip2-log and gzip-log\n" if $logging->bzip2 && $logging->gzip; + + return unless $logging->log || $logging->bzip2 || $logging->gzip || $logging->log_file; + + # We want to keep the log and put it in a findable location + $logging->field(log => 1); + + unless ($logging->log_file) { + my $log_dir = $logging->log_dir // ($settings->check_prefix('workspace') ? $settings->workspace->tmp_dir : File::Spec->tmpdir); + + mkdir($log_dir) or die "Could not create dir '$log_dir': $!" + unless -d $log_dir; + + my $format = $logging->log_file_format; + my $filename = expand_log_file_format($format, $settings); + $logging->field(log_file => clean_path(File::Spec->catfile($log_dir, $filename))); + } + + my $log_file = $logging->log_file; + $log_file =~ s{/+$}{}g; + $log_file =~ s/\.(gz|bz2)$//; + $log_file =~ s/\.jsonl?$//; + $log_file .= "\.jsonl"; + $log_file .= "\.bz2" if $logging->bzip2; + $log_file .= "\.gz" if $logging->gzip; + $logging->field(log_file => $log_file); +} + +sub time_for_strftime { time() } + +sub expand_log_file_format { + my ($pattern, $settings) = @_; + my $before = $pattern; + $pattern =~ s{%!(\w)}{expand($1, $settings)}ge; + my $res = strftime($pattern, localtime(time_for_strftime())); + return $res; +} + +sub expand { + my ($letter, $settings) = @_; + # This could be driven by a hash, but for now if-else is easiest + if ($letter eq "U") { return $settings->run->run_id } + elsif ($letter eq "p") { return $$ } + elsif ($letter eq "P") { + my $project = $settings->harness->project // return ""; + return $project . "~"; + } + elsif ($letter eq "S") { + # Number of seconds since midnight + my ($s, $m, $h) = (localtime(time_for_strftime()))[0, 1, 2]; + return sprintf("%05d", $s + 60 * $m + 3600 * $h); + } + else { + # unrecognized `%!x` expansion. Should we warn? Die? + return "%!$letter"; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Logging - Logging options for yath + +=head1 DESCRIPTION + +This is where the command line options for logging are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Persist.pm b/liby/App/Yath/Options/Persist.pm new file mode 100644 index 000000000..c73e306a7 --- /dev/null +++ b/liby/App/Yath/Options/Persist.pm @@ -0,0 +1,68 @@ +package App::Yath::Options::Persist; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; +use Test2::Harness::Util qw/clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option daemon => ( + description => 'Start the runner as a daemon (Default: True)', + default => 1, + ); +}; + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Persist - Persistent Runner options for Yath. + +=head1 DESCRIPTION + +This is where the command line options for the persistent runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/PreCommand.pm b/liby/App/Yath/Options/PreCommand.pm new file mode 100644 index 000000000..a99c8f387 --- /dev/null +++ b/liby/App/Yath/Options/PreCommand.pm @@ -0,0 +1,177 @@ +package App::Yath::Options::PreCommand; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use App::Yath::Util qw/find_pfile/; +use Test2::Harness::Util qw/mod2file clean_path/; + +use App::Yath::Options; + +option_group {prefix => 'harness', pre_command => 1} => sub { + option plugins => ( + type => 'm', + short => 'p', + alt => ['plugin'], + + category => 'Plugins', + long_examples => [' PLUGIN', ' +App::Yath::Plugin::PLUGIN', ' PLUGIN=arg1,arg2,...'], + short_examples => ['PLUGIN'], + description => 'Load a yath plugin.', + + action => \&plugin_action, + ); + + option no_scan_plugins => ( + type => 'b', + + category => 'Plugins', + description => 'Normally yath scans for and loads all App::Yath::Plugin::* modules in order to bring in command-line options they may provide. This flag will disable that. This is useful if you have a naughty plugin that is loading other modules when it should not.', + ); + + option project => ( + type => 's', + alt => ['project-name'], + category => 'Environment', + description => 'This lets you provide a label for your current project/codebase. This is best used in a .yath.rc file. This is necessary for a persistent runner.', + ); + + option persist_dir => ( + type => 's', + category => 'Environment', + description => 'Where to find persistence files.', + normalize => \&clean_path, + ); + + option persist_file => ( + type => 's', + category => 'Environment', + alt => ['pfile'], + normalize => \&clean_path, + description => "Where to find the persistence file. The default is /{system-tempdir}/project-yath-persist.json. If no project is specified then it will fall back to the current directory. If the current directory is not writable it will default to /tmp/yath-persist.json which limits you to one persistent runner on your system.", + ); + + option dev_libs => ( + type => 'D', + short => 'D', + name => 'dev-lib', + + category => 'Developer', + description => 'Add paths to @INC before loading ANYTHING. This is what you use if you are developing yath or yath plugins to make sure the yath script finds the local code instead of the installed versions of the same code. You can provide an argument (-Dfoo) to provide a custom path, or you can just use -D without and arg to add lib, blib/lib and blib/arch.', + + long_examples => ['', '=lib'], + short_examples => ['', '=lib', 'lib'], + + normalize => \&normalize_dev_libs, + action => \&dev_libs_action, + ); + + post \&post_process; +}; + +sub plugin_action { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler, $options) = @_; + + my ($class, $args) = split /=/, $norm, 2; + $args = [split ',', $args] if $args; + + $class = "App::Yath::Plugin::$class" + unless $class =~ s/^\+//; + + return if grep { $class eq (ref($_) || $_) } @{$settings->harness->plugins}; + + my $file = mod2file($class); + require $file; + + $options->include_from($class) if $class->can('options'); + + my $plugin = $class->can('new') ? $class->new(@{$args // []}) : $class; + + $handler->($slot, $plugin); +} + +sub normalize_dev_libs { + my $val = shift; + + return $val if $val eq '1'; + + return clean_path($val); +} + +sub dev_libs_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my %seen = map { $_ => 1 } @{$$slot}; + + my @new = grep { !$seen{$_}++ } ($norm eq '1') ? (map { clean_path($_) } 'lib', 'blib/lib', 'blib/arch') : ($norm); + + return unless @new; + + warn <<" EOT" for @new; +dev-lib '$_' added to \@INC late, it is possible some yath libraries were already loaded from other paths. +(Maybe you need to move the -D or --dev-lib argument(s) to be earlier in your command line or config file?) + EOT + + unshift @INC => @new; + unshift @{$$slot} => @new; +} + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->harness->field(persist_file => find_pfile($settings, vivify => 1, no_checks => 1)) + unless defined $settings->harness->persist_file; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::PreCommand - Options for yath before command is specified. + +=head1 DESCRIPTION + +This is qhere many pe-commnd options are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Run.pm b/liby/App/Yath/Options/Run.pm new file mode 100644 index 000000000..8d735bb4f --- /dev/null +++ b/liby/App/Yath/Options/Run.pm @@ -0,0 +1,231 @@ +package App::Yath::Options::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Options; + +option_group {prefix => 'run', category => "Run Options", builds => 'Test2::Harness::Run'} => sub { + post \&post_process; + + option link => ( + field => 'links', + type => 'm', + long_examples => [ + " 'https://travis.work/builds/42'", + " 'https://jenkins.work/job/42'", + " 'https://buildbot.work/builders/foo/builds/42'", + ], + description => "Provide one or more links people can follow to see more about this run." + ); + + option test_args => ( + type => 'm', + description => 'Arguments to pass in as @ARGV for all tests that are run. These can be provided easier using the \'::\' argument separator.' + ); + + option input => ( + type => 's', + description => 'Input string to be used as standard input for ALL tests. See also: --input-file', + ); + + option input_file => ( + type => 's', + description => 'Use the specified file as standard input to ALL tests', + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + die "Input file not found: $norm\n" unless -f $norm; + if ($settings->run->input) { + warn "Input file is overriding another source of input.\n"; + $settings->run->field(input => undef); + } + + $handler->($slot, $norm); + }, + ); + + option dbi_profiling => ( + type => 'b', + description => "Use Test2::Plugin::DBIProfile to collect database profiling data", + ); + + option author_testing => ( + short => 'A', + description => 'This will set the AUTHOR_TESTING environment to true', + ); + + option use_stream => ( + name => 'stream', + description => "Use the stream formatter (default is on)", + default => 1, + ); + + option tap => ( + field => 'use_stream', + alt => ['TAP', '--no-stream'], + normalize => sub { $_[0] ? 0 : 1 }, + description => "The TAP format is lossy and clunky. Test2::Harness normally uses a newer streaming format to receive test results. There are old/legacy tests where this causes problems, in which case setting --TAP or --no-stream can help." + ); + + option fields => ( + type => 'm', + short => 'f', + long_examples => [' name:details', ' JSON_STRING'], + short_examples => [' name:details', ' JSON_STRING'], + description => "Add custom data to the harness run", + action => \&fields_action, + ); + + option env_var => ( + field => 'env_vars', + short => 'E', + type => 'h', + long_examples => [' VAR=VAL'], + short_examples => ['VAR=VAL', ' VAR=VAL'], + description => 'Set environment variables to set when each test is run.', + ); + + option run_id => ( + alt => ['id'], + description => 'Set a specific run-id. (Default: a UUID)', + default => \&gen_uuid, + ); + + option load => ( + type => 'm', + short => 'm', + alt => ['load-module'], + description => 'Load a module in each test (after fork). The "import" method is not called.', + ); + + option load_import => ( + type => 'H', + short => 'M', + alt => ['loadim'], + + long_examples => [' Module', ' Module=import_arg1,arg2,...'], + short_examples => [' Module', ' Module=import_arg1,arg2,...'], + + description => 'Load a module in each test (after fork). Import is called.', + ); + + option event_uuids => ( + default => 1, + alt => ['uuids'], + description => 'Use Test2::Plugin::UUID inside tests (default: on)', + ); + + option mem_usage => ( + default => 1, + description => 'Use Test2::Plugin::MemUsage inside tests (default: on)', + ); + + option io_events => ( + default => 0, + description => 'Use Test2::Plugin::IOEvents inside tests to turn all prints into test2 events (default: off)', + ); + + option retry => ( + default => 0, + short => 'r', + type => 's', + description => 'Run any jobs that failed a second time. NOTE: --retry=1 means failing tests will be attempted twice!', + ); + + option retry_isolated => ( + default => 0, + alt => ['retry-iso'], + type => 'b', + description => 'If true then any job retries will be done in isolation (as though -j1 was set)', + ); +}; + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + $settings->run->env_vars->{AUTHOR_TESTING} = 1 if $settings->run->author_testing; + + if ($settings->run->dbi_profiling) { + eval { require Test2::Plugin::DBIProfile; 1 } or die "Could not enable DBI profiling, could not load 'Test2::Plugin::DBIProfile': $@"; + push @{$settings->run->load_import->{'@'}} => 'Test2::Plugin::DBIProfile'; + $settings->run->load_import->{'Test2::Plugin::DBIProfile'} = []; + } +} + +sub fields_action { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + my $fields = ${$slot} //= []; + + if ($norm =~ m/^{/) { + my $field = {}; + my $ok = eval { $field = Test2::Harness::Util::JSON::decode_json($norm); 1 }; + chomp(my $error = $@ // ''); + + die "Error parsing field specification '$field': $error\n" unless $ok; + die "Fields must have a 'name' key (error in '$raw')\n" unless $field->{name}; + die "Fields must habe a 'details' key (error in '$raw')\n" unless $field->{details}; + + return push @$fields => $field; + } + elsif ($norm =~ m/([^:]+):([^:]+)/) { + return push @$fields => {name => $1, details => $2}; + } + + die "'$raw' is not a valid field specification.\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Run - Run options for Yath. + +=head1 DESCRIPTION + +This is where command lines options for a single test run are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Runner.pm b/liby/App/Yath/Options/Runner.pm new file mode 100644 index 000000000..e8bb5feff --- /dev/null +++ b/liby/App/Yath/Options/Runner.pm @@ -0,0 +1,362 @@ +package App::Yath::Options::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use List::Util qw/min/; +use Test2::Util qw/IS_WIN32/; +use App::Yath::Util qw/find_in_updir/; +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use File::Spec; + +use App::Yath::Options; + +my $DEFAULT_COVER_ARGS = '-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; + +option_group {prefix => 'runner', category => "Runner Options"} => sub { + option use_fork => ( + alt => ['fork'], + description => "(default: on, except on windows) Normally tests are run by forking, which allows for features like preloading. This will turn off the behavior globally (which is not compatible with preloading). This is slower, it is better to tag misbehaving tests with the '# HARNESS-NO-PRELOAD' comment in their header to disable forking only for those tests.", + env_vars => [qw/!T2_NO_FORK T2_HARNESS_FORK !T2_HARNESS_NO_FORK YATH_FORK !YATH_NO_FORK/], + default => sub { + return 0 if IS_WIN32; + return 1; + }, + ); + + option abort_on_bail => ( + type => 'b', + default => 1, + description => "Abort all testing if a bail-out is encountered (default: on)", + ); + + option use_timeout => ( + alt => ['timeout'], + description => "(default: on) Enable/disable timeouts", + default => 1, + ); + + option shared_jobs_config => ( + type => 's', + description => 'Where to look for a shared slot config file. If a filename with no path is provided yath will search the current and all parent directories for the name.', + default => '.sharedjobslots.yml', + long_examples => [ ' .sharedjobslots.yml', ' relative/path/.sharedjobslots.yml', ' /absolute/path/.sharedjobslots.yml' ], + ); + + post \&jobs_post_process; + option job_count => ( + type => 's', + short => 'j', + alt => ['jobs'], + description => 'Set the number of concurrent jobs to run. Add a :# if you also wish to designate multiple slots per test. 8:2 means 8 slots, but each test gets 2 slots, so 4 tests run concurrently. Tests can find their concurrency assignemnt in the "T2_HARNESS_MY_JOB_CONCURRENCY" environment variable.', + env_vars => [qw/YATH_JOB_COUNT T2_HARNESS_JOB_COUNT HARNESS_JOB_COUNT/], + clear_env_vars => 1, + long_examples => [' 4', ' 8:2'], + short_examples => ['4', '8:2'], + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + my ($jobs, $slots) = split /:/, $norm; + + $$slot = $jobs; + + $settings->runner->slots_per_job($slots) if defined $slots; + + fix_job_resources($settings); + }, + ); + + option slots_per_job => ( + type => 's', + short => 'x', + description => "This sets the number of slots each job will use (default 1). This is normally set by the ':#' in '-j#:#'.", + env_vars => ['T2_HARNESS_JOB_CONCURRENCY'], + clear_env_vars => 1, + long_examples => [' 2'], + short_examples => ['2'], + ); + + option dump_depmap => ( + type => 'b', + description => "When using staged preload, dump the depmap for each stage as json files", + default => 0, + ); + + option includes => ( + name => 'include', + short => 'I', + type => 'm', + description => "Add a directory to your include paths", + ); + + option resources => ( + name => 'resource', + short => 'R', + type => 'm', + description => "Use a resource module to assign resource assignments to individual tests", + long_examples => [' Port', ' +Test2::Harness::Runner::Resource::Port'], + short_examples => [' Port'], + + normalize => sub { + my $val = shift; + + $val = "Test2::Harness::Runner::Resource::$val" + unless $val =~ s/^\+//; + + return $val; + }, + ); + + option tlib => ( + description => "(Default: off) Include 't/lib' in your module path", + default => 0, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => File::Spec->catdir('t', 'lib'); + }, + ); + + option lib => ( + short => 'l', + description => "(Default: include if it exists) Include 'lib' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + push @{$settings->runner->includes} => 'lib'; + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option blib => ( + short => 'b', + description => "(Default: include if it exists) Include 'blib/lib' and 'blib/arch' in your module path", + default => 1, + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; + + push @{$settings->runner->includes} => ( + File::Spec->catdir('blib', 'lib'), + File::Spec->catdir('blib', 'arch'), + ); + + $settings->runner->lib(0); + $settings->runner->blib(0); + }, + ); + + option unsafe_inc => ( + description => "perl is removing '.' from \@INC as a security concern. This option keeps things from breaking for now.", + env_vars => [qw/PERL_USE_UNSAFE_INC/], + default => 0, + ); + + option preloads => ( + type => 'm', + alt => ['preload'], + short => 'P', + description => 'Preload a module before running tests', + ); + + option preload_threshold => ( + short => 'W', + alt => ['Pt'], + type => 's', + default => 0, + description => "Only do preload if at least N tests are going to be run. In some cases a full preload takes longer than simply running the tests, this lets you specify a minimum number of test jobs that will be run for preload to happen. This has no effect for a persistent runner. The default is 0, and it means always preload." + ); + + option nytprof => ( + type => 'b', + description => "Use Devel::NYTProf on tests. This will set addpid=1 for you. This works with or without fork.", + long_examples => [''], + ); + + post \&cover_post_process; + option cover => ( + type => 'd', + description => "Use Devel::Cover to calculate test coverage. This disables forking. If no args are specified the following are used: $DEFAULT_COVER_ARGS", + long_examples => ['', '=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'], + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = $DEFAULT_COVER_ARGS if $norm eq '1'; + return $$slot = $norm; + }, + ); + + option switch => ( + field => 'switches', + short => 'S', + type => 'm', + description => 'Pass the specified switch to perl for each test. This is not compatible with preload.', + ); + + option event_timeout => ( + alt => ['et'], + + type => 's', + default => 60, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Kill test if no output is received within timeout period. (Default: 60 seconds). Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis. This prevents a hung test from running forever.', + ); + + option post_exit_timeout => ( + alt => ['pet'], + + type => 's', + default => 15, + + long_examples => [' SECONDS'], + short_examples => [' SECONDS'], + description => 'Stop waiting post-exit after the timeout period. (Default: 15 seconds) Some tests fork and allow the parent to exit before writing all their output. If Test2::Harness detects an incomplete plan after the test exits it will monitor for more events until the timeout period. Add the "# HARNESS-NO-TIMEOUT" comment to the top of a test file to disable timeouts on a per-test basis.' + ); + + option runner_id => ( + type => 's', + default => sub { gen_uuid() }, + description => 'Runner ID (usually a generated uuid)', + ); +}; + +sub jobs_post_process { + my %params = @_; + my $settings = $params{settings}; + + my $runner = $settings->runner or return; + + fix_job_resources($settings); + + $ENV{T2_HARNESS_MY_JOB_COUNT} = $runner->job_count; + $ENV{T2_HARNESS_MY_MAX_JOB_CONCURRENCY} = $runner->slots_per_job; +} + +sub fix_job_resources { + my ($settings) = @_; + + my $runner = $settings->runner; + + require Test2::Harness::Runner::Resource::SharedJobSlots::Config; + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + + my %found; + for my $r (@{$runner->resources}) { + require(mod2file($r)); + next unless $r->job_limiter; + $found{$r}++; + } + + if ($sconf && !$found{'Test2::Harness::Runner::Resource::SharedJobSlots'}) { + if (delete $found{'Test2::Harness::Runner::Resource::JobCount'}) { + @{$settings->runner->resources} = grep { $_ ne 'Test2::Harness::Runner::Resource::JobCount' } @{$runner->resources}; + } + + if (!keys %found) { + require Test2::Harness::Runner::Resource::SharedJobSlots; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::SharedJobSlots'; + $found{'Test2::Harness::Runner::Resource::SharedJobSlots'}++; + } + } + elsif (!keys %found) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$runner->resources} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + if ($found{'Test2::Harness::Runner::Resource::SharedJobSlots'} && $sconf) { + $runner->field(job_count => $sconf->default_slots_per_run || $sconf->max_slots_per_run) if $runner && !$runner->job_count; + $runner->field(slots_per_job => $sconf->default_slots_per_job || $sconf->max_slots_per_job) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "Requested job count ($run_slots) exceeds the system shared limit (" . $sconf->max_slots_per_run . ").\n" + if $run_slots > $sconf->max_slots_per_run; + + die "Requested job concurrency ($job_slots) exceeds the system shared limit (" . $sconf->max_slots_per_job . ").\n" + if $job_slots > $sconf->max_slots_per_job; + } + + $runner->field(job_count => 1) if $runner && !$runner->job_count; + $runner->field(slots_per_job => 1) if $runner && !$runner->slots_per_job; + + my $run_slots = $runner->job_count; + my $job_slots = $runner->slots_per_job; + + die "The slots_per_job (set to $job_slots) must not be larger than the job_count (set to $run_slots).\n" if $job_slots > $run_slots; +} + +sub cover_post_process { + my %params = @_; + my $settings = $params{settings}; + + if ($ENV{T2_DEVEL_COVER} && !$settings->runner->cover) { + $settings->runner->field(cover => $ENV{T2_DEVEL_COVER} eq '1' ? $ENV{T2_DEVEL_COVER} : $DEFAULT_COVER_ARGS); + } + + return unless $settings->runner->cover; + + # For nested things + $ENV{T2_NO_FORK} = 1; + $ENV{T2_DEVEL_COVER} = $settings->runner->cover; + $settings->runner->field(use_fork => 0); + + return unless $settings->check_prefix('run'); + push @{$settings->run->load_import->{'@'}} => 'Devel::Cover'; + $settings->run->load_import->{'Devel::Cover'} = [split(/,/, $settings->runner->cover)]; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Runner - Runner options for Yath. + +=head1 DESCRIPTION + +This is where command line options for the runner are defined. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Options/Workspace.pm b/liby/App/Yath/Options/Workspace.pm new file mode 100644 index 000000000..752306e66 --- /dev/null +++ b/liby/App/Yath/Options/Workspace.pm @@ -0,0 +1,115 @@ +package App::Yath::Options::Workspace; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); +use File::Path qw/remove_tree/; +use File::Temp qw/tempdir/; + +use Test2::Harness::Util qw/clean_path chmod_tmp/; + +use App::Yath::Options; + +option_group {prefix => 'workspace', category => "Workspace Options"} => sub { + option tmp_dir => ( + type => 's', + short => 't', + alt => ['tmpdir'], + description => 'Use a specific temp directory (Default: use system temp dir)', + env_vars => [qw/T2_HARNESS_TEMP_DIR YATH_TEMP_DIR TMPDIR TEMPDIR TMP_DIR TEMP_DIR/], + default => sub { File::Spec->tmpdir }, + ); + + option workdir => ( + type => 's', + short => 'w', + description => 'Set the work directory (Default: new temp directory)', + env_vars => [qw/T2_WORKDIR YATH_WORKDIR/], + clear_env_vars => 1, + normalize => \&clean_path, + ); + + option clear => ( + short => 'C', + description => 'Clear the work directory if it is not already empty', + ); + + post sub { + my %params = @_; + my $settings = $params{settings}; + + if (my $workdir = $settings->workspace->workdir) { + if (-d $workdir) { + remove_tree($workdir, {safe => 1, keep_root => 1}) if $settings->workspace->clear; + } + else { + mkdir($workdir) or die "Could not create workdir: $!"; + chmod_tmp($workdir); + } + + return; + } + + my $project = $settings->harness->project; + my $template = join '-' => ( "yath", $$, "XXXXXX"); + + my $tmpdir = tempdir( + $template, + DIR => $settings->workspace->tmp_dir, + CLEANUP => !($settings->debug->keep_dirs || $params{command}->always_keep_dir), + ); + chmod_tmp($tmpdir); + + $settings->workspace->field(workdir => $tmpdir); + }; +}; + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Options::Workspace - Options for specifying the yath work dir. + +=head1 DESCRIPTION + +Options regarding the yath working directory. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin.pm b/liby/App/Yath/Plugin.pm new file mode 100644 index 000000000..b0c0c583a --- /dev/null +++ b/liby/App/Yath/Plugin.pm @@ -0,0 +1,180 @@ +package App::Yath::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Plugin'; + +# We do not want this defined by default, but it should be documented +#sub handle_event {} +#sub sort_files {} +#sub sort_files_2 {} + +sub finish {} + +sub finalize {} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin - Base class for yath plugins + +=head1 DESCRIPTION + +This is a base class for yath plugins. Note this class also subclasses +L<Test2::Harness::Plugin>. + +This class holds the methods specific to yath, which is the UI layer. +L<Test2::Harness::Plugin> holds the methods specific to L<Test2::Harness> which +is the backend. + +=head1 SYNOPSIS + + package App::Yath::Plugin::MyPlugin; + + use parent 'App::Yath::Plugin'; + + # ... Define methods + + 1; + + +Then to use it at the command line: + + $ yath -pMyPlugin ... + +=head1 NOTE ON INSTANCE VS CLASS + +None of the plugin base classes provide a C<new()> method. By default plugins +are not instantiated and only the plugin package name is passed around. All +methods are then called on the class. + +If you want your plugin to be instantiated as an object you need only define a +C<new()> method. If this method is defined yath will call it and create an +instance. The instance created will then be used when calling all the methods. + +To pass arguments to the constructor you can use +C<yath -pYourPlugin=arg1,arg2,arg3...>. Your plugin can also define options +using L<App::Yath::Options> which will be dropped into the C<$settings> that +get passed around. + +=head1 METHODS + +B<Note:> See L<Test2::Harness::Plugin> for additional method you can implement/override + +=over 4 + +=item $plugin->handle_event($event, $settings) + +Called for every single event that yath sees. Note that this method is not +defined by default for performance reasons, however it will be called if you +define it. + +=item @sorted = $plugin->sort_files_2(settings => $settings, files => \@unsorted) + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +If this is present then C<sort_files()> will be ignored. + +=item @sorted = $plugin->sort_files(@unsorted) + +B<DEPRECATED> Use C<sort_files_2()> instead. + +This gives your plugin a chance to sort the files before they are added to the +queue. Other things are done later to re-order the files optimally based on +length or category, so this sort is just for initial job numbering, and to +define a base order before optimization takes place. + +All files to sort will be instances of L<Test2::Harness::TestFile>. + +This method is normally left undefined, but will be called if you define it. + +=item $plugin->finish(%args) + +This is what arguments are recieved: + + ( + settings => $settings, # The settings + final_data => $final_data, # See below + pass => $pass ? 1 : 0, # Always a 0 or 1 + tests_seen => $self->{+TESTS_SEEN} // 0, # Integer 0 or greater + asserts_seen => $self->{+ASSERTS_SEEN} // 0, # Integer 0 or greater + ) + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=item $plugin->finalize($settings) + +This is called as late as possible before exit. This is mainly useful for +outputting messages such as "Extra log file written to ..." which are best put +at the end of output. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin/Cover.pm b/liby/App/Yath/Plugin/Cover.pm new file mode 100644 index 000000000..ef46b9514 --- /dev/null +++ b/liby/App/Yath/Plugin/Cover.pm @@ -0,0 +1,458 @@ +package App::Yath::Plugin::Cover; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::JSON qw/encode_json stream_json_l/; +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-aggregator -no_aggregate +metrics +outfile/; + +use App::Yath::Options; + +option_group {prefix => 'cover', category => "Cover Options"} => sub { + post \&post_process; + + option types => ( + alt => ['cover-type'], + type => 'm', + default => sub { [qw/pl pm/] }, + ); + + option dirs => ( + alt => ['cover-dir'], + type => 'm', + default => sub { ['lib'] }, + + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + push @$$slot => glob($norm); + }, + ); + + option exclude_private => ( + type => 'b', + default => 0, + description => "", + ); + + option files => ( + type => 'b', + description => "Use Test2::Plugin::Cover to collect coverage data for what files are touched by what tests. Unlike Devel::Cover this has very little performance impact (About 4% difference)", + ); + + option metrics => ( + type => 'b', + description => '', + ); + + option write => ( + type => 'd', + normalize => \&clean_path, + long_examples => ['', '=coverage.jsonl', '=coverage.json'], + description => "Create a json or jsonl file of all coverage data seen during the run (This implies --cover-files).", + action => sub { + my ($prefix, $field, $raw, $norm, $slot, $settings) = @_; + + return $$slot = clean_path("coverage.jsonl") if $raw eq '1'; + return $$slot = $norm; + }, + ); + + option aggregator => ( + alt => ['cover-agg'], + type => 's', + long_examples => [' ByTest', ' ByRun', ' +Custom::Aggregator'], + description => 'Choose a custom aggregator subclass', + normalize => sub { + my ($agg) = @_; + return $agg if $agg =~ s/^\+//; + return "Test2::Harness::Log::CoverageAggregator::$agg"; + }, + ); + + option class => ( + type => 's', + description => 'Choose a Test2::Plugin::Cover subclass', + default => 'Test2::Plugin::Cover', + ); + + option manager => ( + type => 's', + description => "Coverage 'from' manager to use when coverage data does not provide one", + long_examples => [ ' My::Coverage::Manager'], + applicable => \&changes_applicable, + ); + + option from_type => ( + type => 's', + description => 'File type for coverage source. Usually it can be detected, but when it cannot be you should specify. "json" is old style single-blob coverage data, "jsonl" is the new by-test style, "log" is a logfile from a previous run.', + long_examples => [' json', ' jsonl', ' log' ], + ); + + option maybe_from_type => ( + type => 's', + 'description' => 'Same as "from_type" but for "maybe_from". Defaults to "from_type" if that is specified, otherwise auto-detect', + long_examples => [' json', ' jsonl', ' log' ], + ); + + option from => ( + type => 's', + description => "This can be a test log, a coverage dump (old style json or new jsonl format), or a url to any of the previous. Tests will not be run if the file/url is invalid.", + long_examples => [' path/to/log.jsonl', ' http://example.com/coverage', ' path/to/coverage.jsonl'] + ); + + option maybe_from => ( + type => 's', + description => "This can be a test log, a coverage dump (old style json or new jsonl format), or a url to any of the previous. Tests will coninue if even if the coverage file/url is invalid.", + long_examples => [' path/to/log.jsonl', ' http://example.com/coverage', ' path/to/coverage.jsonl'] + ); +}; + +sub changes_applicable { + my ($option, $options) = @_; + + # Cannot use this options with projects + return 0 if $options->command_class && $options->command_class->isa('App::Yath::Command::projects'); + return 1; +} + +sub spawn_args { + my $self = shift; + my ($settings) = @_; + + return () unless $settings->cover->files || $settings->cover->metrics || $settings->cover->write; + + my $class = $settings->cover->class; + return ('-M' . $class . '=disabled,1'); +} + +sub post_process { + my %params = @_; + my $settings = $params{settings}; + + my $cover = $settings->cover; + + if ($cover->files || $cover->write || $cover->metrics) { + my $cover_class = $cover->class // 'Test2::Plugin::Cover'; + + eval { require(mod2file($cover_class)); 1 } or die "Could not enable file coverage, could not load '$cover_class': $@"; + push @{$settings->run->load_import->{'@'}} => $cover_class; + $settings->run->load_import->{$cover_class} = []; + } +} + +sub annotate_event { + my $self = shift; + return if $self->{+NO_AGGREGATE}; + my ($e, $settings) = @_; + + unless ($self->{+AGGREGATOR}) { + my $do_cover = $settings->cover->files; + my $file = $settings->cover->write; + my $metrics = $settings->cover->metrics; + + unless ($file || $metrics || $do_cover) { + $self->{+NO_AGGREGATE} = 1; + return; + } + + my $agg = $settings->cover->aggregator; + if (!$agg) { + if ($file) { + if ($file =~ m/\.json$/) { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByRun'; + } + elsif ($file =~ m/\.jsonl$/) { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + } + else { + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + } + + my $encode; + if ($agg eq 'Test2::Harness::Log::CoverageAggregator::ByRun') { + $encode = \&encode_json; + } + elsif ($agg eq 'Test2::Harness::Log::CoverageAggregator::ByTest') { + $encode = sub { encode_json($_[0]) . "\n" }; + } + + require(mod2file($agg)); + $self->{+AGGREGATOR} = $agg->new( + $file ? (file => $file) : (), + $encode ? (encode => $encode) : (), + ); + } + + my $fd = $e->{facet_data}; + + my @out; + + if ($fd->{coverage} || $fd->{harness_job_end} || $fd->{harness_job_start}) { + if (my $list = $self->{+AGGREGATOR}->process_event($e)) { + die "Aggregator flushed without a job end!" unless $fd->{harness_job_end}; + die "Aggregator flushed more than 1 job!" unless @$list == 1; + push @out => (job_coverage => {details => 'Job Coverage', manager => $list->[0]->{manager}, files => $list->[0]->{files}, test => $list->[0]->{test}}); + } + } + + if ($fd->{harness_final}) { + my $cover = $settings->cover; + my $aggregator = $self->{+AGGREGATOR} or return; + my $metrics = $self->metrics($settings) if $cover->metrics; + my $final = $aggregator->finalize(); + + my $percentages = $self->_percentages($metrics); + my $raw = join ", ", map { "$_->[0]: $_->[2]/$_->[1] ($_->[3])" } @$percentages; + my $details = join ", ", map { "$_->[0] $_->[3]" } @$percentages; + + $details = "coverage metrics" unless length $details; + + push @out => ( + run_fields => [ + {name => 'coverage', details => $details, data => $metrics, $raw ? (raw => $raw) : ()}, + ], + ); + + push @out => ( + run_coverage => { + details => 'Run Coverage', + files => $final->[0]->{files}, + testmeta => $final->[0]->{testmeta}, + }, + ) if $final && @$final; + } + + return @out; +} + +sub metrics { + my $self = shift; + my ($settings) = @_; + + my $cover = $settings->cover; + + return unless $cover->metrics; + + my $aggregator = $self->{+AGGREGATOR}; + + return $self->{+METRICS} //= $aggregator->build_metrics( + dirs => $cover->dirs, + types => $cover->types, + exclude_private => $cover->exclude_private, + ); +} + +sub _percentages { + my $self = shift; + my ($metrics) = @_; + + return unless $metrics; + + my @out; + + for my $metric (sort keys %$metrics) { + next if $metric eq 'untested'; + my $data = $metrics->{$metric} or next; + my ($total, $tested) = @{$data}{qw/total tested/}; + push @out => [$metric, $total, $tested, $total ? (int(($tested / $total) * 100) . '%') : '100%']; + } + + return \@out; +} + +sub finalize { + my $self = shift; + my ($settings) = @_; + + my $cover = $settings->cover; + my $file = $cover->write; + my $metrics = $cover->metrics; + + return unless $file || $metrics; + print "\nCoverage:\n"; + + my $aggregator = $self->{+AGGREGATOR}; + + if ($metrics) { + my $data = $self->metrics($settings); + + require Term::Table; + my $table = Term::Table->new( + header => [qw/METRIC TOTAL TESTED PERCENTAGE/], + rows => $self->_percentages($data), + ); + print map { "$_\n" } $table->render; + } + + print "Wrote coverage file: $file\n" if $file; + + print "\n"; +} + +sub _deduce_content_type { + my ($path, $type) = @_; + + if ($type) { + if ($type eq 'json') { + return { + content_type => 'application/json', + parser => 'json', + format => $type, + }; + } + elsif ($type eq 'jsonl' || $type eq 'log') { + return { + content_type => 'application/jsonl', + parser => 'jsonl', + format => $type, + }; + } + } + + if ($path =~ m/\.jsonl/) { + return { + content_type => 'application/jsonl', + parser => 'jsonl', + format => undef, + }; + } + + if ($path =~ m/\.json/) { + return { + content_type => 'application/json', + parser => 'json', + format => undef, + }; + } + + return {}; +} + +sub get_coverage_tests { + my $self = shift; + my ($settings, $changes) = @_; + + my $cover = $settings->cover; + my $from = $cover->from; + my $maybe = $cover->maybe_from; + + return unless $from || $maybe; + + if ($maybe) { + my $type_data = $self->_deduce_content_type($maybe, $cover->maybe_from_type); + + my @out; + my $ok = eval { @out = $self->_get_coverage_tests($settings, $changes, $maybe, $type_data); 1 }; + my $err = $@; + return @out if $ok; + warn "Could not get coverage from '$maybe', continuing anyway... error was: $err"; + } + + return $self->_get_coverage_tests($settings, $changes, $from) + if $from; + + return; +} + +sub _get_coverage_tests { + my $self = shift; + my ($settings, $changes, $source, $type_data) = @_; + + my @out; + + stream_json_l( + $source => sub { push @out => $self->coverage_handler($settings, $changes, $type_data, @_) }, + $type_data->{content_type} ? (http_args => [{headers => {'Content-Type' => $type_data->{content_type}}}]) : (), + ); + + return @out; +} + +sub coverage_handler { + my $self = shift; + my ($settings, $changes, $type_data, $set, $res) = @_; + + return unless $set; + + my ($agg, $data); + if (my $fd = $set->{facet_data}) { + if ($data = $fd->{job_coverage}) { + require 'Test2/Harness/Log/CoverageAggregator/ByTest.pm' unless $INC{'Test2/Harness/Log/CoverageAggregator/ByTest.pm'}; + $agg = 'Test2::Harness::Log::CoverageAggregator::ByTest'; + } + elsif($data = $fd->{run_coverage}) { + require 'Test2/Harness/Log/CoverageAggregator/ByRun.pm' unless $INC{'Test2/Harness/Log/CoverageAggregator/ByRun.pm'}; + $agg = 'Test2::Harness::Log::CoverageAggregator::ByRun'; + } + else { + return; + } + } + else { + $data = $set; + $agg = $set->{aggregator} // return; + my $aggfile = mod2file($agg); + require($aggfile) unless $INC{$aggfile}; + } + + return $agg->get_coverage_tests($settings, $changes, $data); +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Cover - Plugin to collect and report basic coverage data + +=head1 DESCRIPTION + +Simple coverage data, file and sub coverage only. Use L<Devel::Cover> if you +want deep coverage stats. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin/Git.pm b/liby/App/Yath/Plugin/Git.pm new file mode 100644 index 000000000..0974fc723 --- /dev/null +++ b/liby/App/Yath/Plugin/Git.pm @@ -0,0 +1,208 @@ +package App::Yath::Plugin::Git; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IPC::Cmd qw/can_run/; +use Test2::Harness::Util::IPC qw/run_cmd/; +use parent 'App::Yath::Plugin'; + +use App::Yath::Options; + +option_group {prefix => 'git', category => "Git Options"} => sub { + option change_base => ( + type => 's', + description => "Find files changed by all commits in the current branch from most recent stopping when a commit is found that is also present in the history of the branch/commit specified as the change base.", + long_examples => [" master", " HEAD^", " df22abe4"], + ); +}; + +my $GIT_CMD = can_run('git'); +sub git_cmd { $ENV{GIT_COMMAND} || $GIT_CMD } + +sub git_output { + my $class = shift; + my (@args) = @_; + + my $cmd = $class->git_cmd or return sub {()}; + + my ($rh, $wh, $irh, $iwh); + pipe($rh, $wh) or die "No pipe: $!"; + pipe($irh, $iwh) or die "No pipe: $!"; + my $pid = run_cmd(stderr => $iwh, stdout => $wh, command => [$cmd, @args]); + + close($wh); + close($iwh); + + $rh->blocking(1); + $irh->blocking(0); + + my $waited = 0; + return sub { + my $line = <$rh>; + return $line if defined $line; + + unless ($waited++) { + local $?; + waitpid($pid, 0); + print STDERR <$irh> if $?; + close($irh); + + # Try again + $line = <$rh>; + return $line if defined $line; + } + + close($rh); + return; + }; +} + +sub inject_run_data { + my $class = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + my $long_sha = $ENV{GIT_LONG_SHA}; + my $short_sha = $ENV{GIT_SHORT_SHA}; + my $status = $ENV{GIT_STATUS}; + my $branch = $ENV{GIT_BRANCH}; + + my @sets = ( + [\$long_sha, 'rev-parse', 'HEAD'], + [\$short_sha, 'rev-parse', '--short', 'HEAD'], + [\$status, 'status', '-s'], + [\$branch, 'rev-parse', '--abbrev-ref', 'HEAD'], + ); + + for my $set (@sets) { + my ($var, @args) = @$set; + next if $$var; # Already set + my $output = $class->git_output(@args); + + my @lines; + while (my $line = $output->()) { + push @lines => $line; + } + + chomp($$var = join "\n" => @lines); + } + + return unless $long_sha; + + $meta->{git}->{sha} = $long_sha; + $meta->{git}->{status} = $status if $status; + + if ($branch) { + $meta->{git}->{branch} = $branch; + + my $short = length($branch) > 20 ? substr($branch, 0, 20) : $branch; + + push @$fields => {name => 'git', details => $short, raw => $branch, data => $meta->{git}}; + } + else { + $short_sha ||= substr($long_sha, 0, 16); + push @$fields => {name => 'git', details => $short_sha, raw => $long_sha, data => $meta->{git}}; + } + + return; +} + +sub changed_diff { + my $class = shift; + my ($settings) = @_; + + $class->_changed_diff($settings->git->change_base); +} + +sub _changed_diff { + my $class = shift; + my ($base) = @_; + + my $cmd = $class->git_cmd or return; + + my $from = 'HEAD'; + + if ($base) { + $from .= "^" while system($cmd => 'merge-base', '--is-ancestor', $from, $base); + return $class->_diff_from($from); + } + + my @files = $class->_diff_from($from); + return @files if @files; + + return $class->_diff_from("${from}^"); +} + +sub _diff_from { + my $class = shift; + my ($from) = @_; + my $cmd = $class->git_cmd or return; + + return (line_sub => $class->git_output('diff', '-U1000000', '-W', '--minimal', $from)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Git - Plugin to attach git data to a test run. + +=head1 DESCRIPTION + +This plugin will attach git data to your test logs if any is available. + +=head1 SYNOPSIS + + $ yath test -pGit ... + +=head1 READING THE DATA + +The data is attached to the 'run' entry in the log file. This can be seen +directly in the json data. The data is also easily accessible with +L<Test2::Harness::UI>. + +The data will include the long sha, short sha, branch name, and a brief status. + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin/Notify.pm b/liby/App/Yath/Plugin/Notify.pm new file mode 100644 index 000000000..56b0a9c3c --- /dev/null +++ b/liby/App/Yath/Plugin/Notify.pm @@ -0,0 +1,631 @@ +package App::Yath::Plugin::Notify; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::JSON qw/encode_json/; +use Test2::Harness::Util qw/mod2file/; + +use Sys::Hostname qw/hostname/; + +use Carp qw/croak confess/; + +use App::Yath::Options; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-final -tries -problems -problem_cids +text_mod +text_mod_handles_events +text_mod_fail/; + +# Notifications only apply to commands which build a run. +sub applicable { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Run'}; + return 0; +} + +option_group {prefix => 'notify', category => "Notification Options", applicable => \&applicable} => sub { + option slack => ( + type => 'm', + description => "Send results to a slack channel and/or user", + long_examples => [" '#foo'", " '\@bar'"], + ); + + option slack_fail => ( + type => 'm', + description => "Send failing results to a slack channel and/or user", + long_examples => [" '#foo'", " '\@bar'"], + ); + + option slack_url => ( + type => 's', + description => "Specify an API endpoint for slack webhook integrations", + long_examples => [" https://hooks.slack.com/..."], + ); + + option slack_owner => ( + type => 'b', + description => "Send slack notifications to the slack channels/users listed in test meta-data when tests fail.", + default => 0, + ); + + option no_batch_slack => ( + type => 'b', + default => 0, + description => 'Usually owner failures are sent as a single batch at the end of testing. Toggle this to send failures as they happen.', + ); + + option email_from => ( + type => 's', + long_examples => [' foo@example.com'], + description => "If any email is sent, this is who it will be from", + default => sub { + my $user = getlogin() || scalar(getpwuid($<)) || $ENV{USER} || 'unknown'; + my $host = hostname() || 'unknown'; + return "${user}\@${host}"; + }, + ); + + option email => ( + type => 'm', + long_examples => [' foo@example.com'], + description => "Email the test results to the specified email address(es)", + ); + + option email_fail => ( + type => 'm', + long_examples => [' foo@example.com'], + description => "Email failing results to the specified email address(es)", + ); + + option email_owner => ( + type => 'b', + description => 'Email the owner of broken tests files upon failure. Add `# HARNESS-META-OWNER foo@example.com` to the top of a test file to give it an owner', + default => 0, + ); + + option no_batch_email => ( + type => 'b', + default => 0, + description => 'Usually owner failures are sent as a single batch at the end of testing. Toggle this to send failures as they happen.', + ); + + option text => ( + type => 's', + alt => ['message', 'msg'], + description => "Add a custom text snippet to email/slack notifications", + ); + + option text_module => ( + type => 's', + alt => ['message_module'], + description => "Use the specified module to generate messages for emails and/or slack.", + ); + + post sub { + my %params = @_; + + my $settings = $params{settings}; + my $options = $params{options}; + + my $set_by_cli = $options->set_by_cli->{notify}; + + # Should we use email? + if (@{$settings->notify->email} || $settings->notify->email_owner) { + $settings->notify->field(email_owner => 1) unless $set_by_cli->{email_owner}; + + # Do we have Email::Stuffer? + eval { require Email::Stuffer; 1 } or die "Cannot use --email-owner without Email::Stuffer, which is not installed.\n"; + + push @{$settings->harness->plugins} => __PACKAGE__->new() unless grep { $_->isa(__PACKAGE__) } @{$settings->harness->plugins}; + } + + my $use_slack = grep { $settings->notify->$_ } qw/slack_url slack_owner/; + $use_slack ||= grep { @{$settings->notify->$_} } qw/slack slack_fail/; + if ($use_slack) { + die "slack url must be provided in order to use slack" unless $settings->notify->slack_url; + + eval { require HTTP::Tiny; 1 } or die "Cannot use slack without HTTP::Tiny which is not installed.\n"; + + die "HTTP::Tiny reports that it does not support SSL, cannot use slack without ssl." + unless HTTP::Tiny::can_ssl(); + + $settings->notify->field(slack_owner => 1) unless $set_by_cli->{slack_owner}; + + push @{$settings->harness->plugins} => __PACKAGE__->new() unless grep { $_->isa(__PACKAGE__) } @{$settings->harness->plugins}; + } + }; +}; + +sub text_mod { + my $self = shift; + my ($settings) = @_; + + croak 'settings is a required argument' unless $settings; + + return $self->{+TEXT_MOD} if exists $self->{+TEXT_MOD}; + + if (my $tm = $settings->notify->text_module) { + my $file = mod2file($tm); + if (eval { require $file; 1 }) { + my $inst = $tm->can('new') ? $tm->new() : $tm; + $self->{+TEXT_MOD_HANDLES_EVENTS} = $inst->can('handle_event') ? 1 : 0; + return $self->{+TEXT_MOD} = $inst; + } + else { + my $err = $@; + warn "Cannot use module '$tm' for notification text generation: $err"; + chomp($self->{+TEXT_MOD_FAIL} = $err); + } + } + + $self->{+TEXT_MOD_HANDLES_EVENTS} = 0; + return $self->{+TEXT_MOD} = undef; +} + +sub handle_event { + my $self = shift; + my ($e, $settings) = @_; + + my $f = $e->facet_data; + + $self->record_problem($f); + + my $tm = $self->text_mod($settings); + if ($tm && $self->{+TEXT_MOD_HANDLES_EVENTS}) { + $tm->handle_event($e, $f, settings => $settings, notify => $self); + } + + return $self->handle_job_end($e, $f, $settings) if $f->{harness_job_end}; + return $self->handle_final($e, $f, $settings) if $f->{harness_final}; + + return; +} + +sub record_problem { + my $self = shift; + my ($f) = @_; + + return unless $self->has_fail_or_error($f); + + my $job_id = $f->{harness}->{job_id}; + my $job_try = $f->{harness}->{job_try} // 0; + + push @{$self->{+PROBLEMS}->{$job_id}->{$job_try}} => $self->prune_subtests($f); +} + +sub has_fail_or_error { + my $self = shift; + my ($f, %params) = @_; + + return 0 if $f->{trace}->{nested} && !$params{allow_nested}; + return 0 if $f->{amnesty} && @{$f->{amnesty}}; + + my $out = 0; + + my $cid = $f->{trace}->{cid}; + $out = 1 if $cid && $self->{+PROBLEM_CIDS}->{$cid} && $f->{info} && @{$f->{info}}; + $out = 1 if $f->{errors} && @{$f->{errors}}; + $out = 1 if $f->{assert} && !$f->{assert}->{pass}; + + $self->{+PROBLEM_CIDS}->{$cid} = 1 if $cid && $out; + + return $out; +} + +sub prune_subtests { + my $self = shift; + my ($f) = @_; + + my $p = $f->{parent} // return $f; + my $c = $p->{children} // return $f; + + return $f unless @$c; + + my $out = {}; + $out->{$_} = $f->{$_} for grep { $f->{$_} } qw/assert about trace errors info harness control/; + $out->{parent} = {%$p, children => [map { $self->prune_subtests($_) } grep { $self->has_fail_or_error($_, allow_nested => 1) } @$c]}; + + return $out; +} + +sub handle_final { + my $self = shift; + my ($e, $f, $settings) = @_; + + $self->{+FINAL} = $e; +} + +sub handle_job_end { + my $self = shift; + my ($e, $f, $settings) = @_; + + return unless $f->{harness_job_end}->{fail}; + + my $job_id = $f->{harness}->{job_id}; + + if ($f->{harness_job_end}->{retry}) { + $self->{+TRIES}->{$job_id}++; + return; + } + + my @args = ($e, $f, $self->{+TRIES}->{$job_id}, $settings); + + $self->send_job_notification_slack(@args); + $self->send_job_notification_email(@args); +} + +sub send_job_notification_slack { + my $self = shift; + + my ($e, $f, $tries, $settings) = @_; + + return unless $settings->notify->no_batch_slack; + + my $tf = Test2::Harness::TestFile->new(file => $f->{harness_job_end}->{abs_file}); + + my @slack; + push @slack => $tf->meta('slack') if $settings->notify->slack_owner; + push @slack => @{$settings->notify->slack_fail}; + + return unless @slack; + + my $text = $self->gen_text(scope => 'job', service => 'slack', settings => $settings, file => $tf, tries => $tries); + + $self->_send_slack($text, $settings, @slack); +} + +sub gen_slack_job_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $tf = $params{file} // croak "'file' is required"; + my $tries = $params{tries} // 0; + + my $host = hostname(); + my $file = $tf->relative; + + return join "\n\n" => grep { $_ } + $settings->notify->text, + "Failed test on $host: '$file'.", + $tries ? ("Test was run " . (1 + $tries) . " time(s).") : (), + join "\n" => map {"> <$_|$_>"} @{$settings->run->links}; +} + +sub _send_slack { + my $self = shift; + my ($text, $settings, @to) = @_; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + for my $dest (@to) { + my $r = $ht->post( + $settings->notify->slack_url, + { + headers => {'content-type' => 'application/json'}, + content => encode_json({channel => $dest, text => $text}), + }, + ); + warn "Failed to send slack message to '$dest'" unless $r->{success}; + } +} + +sub send_job_notification_email { + my $self = shift; + + my ($e, $f, $tries, $settings) = @_; + + return unless $settings->notify->no_batch_email; + + my $tf = Test2::Harness::TestFile->new(file => $f->{harness_job_end}->{abs_file}); + + my @to; + push @to => $tf->meta('owner') if $settings->notify->email_owner; + push @to => @{$settings->notify->email_fail}; + return unless @to; + + my $text = $self->gen_text(scope => 'job', service => 'email', settings => $settings, file => $tf, tries => $tries); + my $subject = "Failed test on " . hostname() . ": '" . $tf->relative . "'."; + + $self->_send_email($subject, $text, $settings, @to); +} + +sub gen_email_job_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $tf = $params{file} // croak "'file' is required"; + my $tries = $params{tries} // 0; + + my $host = hostname(); + my $file = $tf->relative; + + return join "\n\n" => grep { $_ } + $settings->notify->text, + "Failed test on $host: '$file'.", + $tries ? ("Test was run " . (1 + $tries) . " time(s).") : (), + join "\n" => @{$settings->run->links}; +} + +sub _send_email { + my $self = shift; + my ($subject, $text, $settings, @to) = @_; + + my $mail = Email::Stuffer->to(@to); + $mail->from($settings->notify->email_from); + $mail->subject($subject); + + my $rtype = ref($text) // ''; + + if (!$rtype) { + $mail->text_body($text); + } + elsif ($rtype eq 'HASH') { + $mail->text_body($text->{text}) if $text->{text}; + $mail->html_body($text->{html}) if $text->{html}; + } + else { + warn "Invalid text type: '$rtype'"; + } + + eval { $mail->send_or_die; 1 } or warn $@; +} + +sub finish { + my $self = shift; + my %params = @_; + my $settings = $params{settings}; + + my $e = $self->{+FINAL} or return; + my $f = $e->facet_data or return; + my $final = $f->{harness_final} or return; + + $self->send_run_notification_slack($final, $settings); + $self->send_run_notification_email($final, $settings); +} + +sub send_run_notification_slack { + my $self = shift; + my ($final, $settings) = @_; + + return if $settings->notify->no_batch_slack; + + my @to = @{$settings->notify->slack}; + push @to => @{$settings->notify->slack_fail} unless $final->{pass}; + + my $files = ""; + if ($final->{failed}) { + for my $set (@{$final->{failed}}) { + my $file = $set->[1]; + + $files = $files ? "$files\n$file" : $file; + + next unless $settings->notify->slack_owner; + my $tf = Test2::Harness::TestFile->new(file => $file); + push @to => $tf->meta('slack'); + } + } + + return unless @to; + + my $text = $self->gen_text( + scope => 'run', + service => 'slack', + settings => $settings, + final => $final, + files => $files, + ); + + $self->_send_slack($text, $settings, @to); +} + +sub gen_slack_run_text { + my $self = shift; + my %params = @_; + + my $settings = $params{settings} // croak "'settings' is required"; + my $final = $params{final} // croak "'final' is required"; + my $files = $params{files} // ''; + + my $host = hostname(); + + return join "\n\n" => grep { $_ } ( + $settings->notify->text, + ($final->{pass} ? "Tests passed on $host" : "Tests failed on $host"), + ($files ? $files : ()), + join("\n" => map {"> <$_|$_>"} @{$settings->run->links}), + ); +} + +sub send_run_notification_email { + my $self = shift; + my ($final, $settings) = @_; + + return if $settings->notify->no_batch_email; + + my @to = @{$settings->notify->email}; + push @to => @{$settings->notify->email_fail} unless $final->{pass}; + + my $files = ""; + if ($final->{failed}) { + for my $set (@{$final->{failed}}) { + my $file = $set->[1]; + + $files = $files ? "$files\n$file" : $file; + + next unless $settings->notify->email_owner; + my $tf = Test2::Harness::TestFile->new(file => $file); + push @to => $tf->meta('owner'); + } + } + + return unless @to; + + my $subject = $self->gen_text( + scope => 'run', + service => 'email_subject', + settings => $settings, + final => $final, + files => $files, + ); + + my $text = $self->gen_text( + scope => 'run', + service => 'email', + settings => $settings, + final => $final, + files => $files, + subject => $subject, + ); + + $self->_send_email($subject, $text, $settings, @to); +} + +sub gen_email_subject_run_text { + my $self = shift; + my %params = @_; + + my $final = $params{final} // croak "'final' is required"; + my $host = hostname(); + + return $final->{pass} ? "Tests passed on $host" : "Tests failed on $host"; +} + +sub gen_email_run_text { + my $self = shift; + my %params = @_; + + my $subject = $params{subject} // $self->gen_text(%params, service => 'email_subject'); + my $settings = $params{settings} // croak "'settings' is required"; + my $final = $params{final} // croak "'final' is required"; + my $files = $params{files} // ''; + + return join "\n\n" => grep { $_ } ( + $settings->notify->text, + $subject, + ($files ? $files : ()), + join("\n" => @{$settings->run->links}), + ); +} + +sub gen_text { + my $self = shift; + my %params = @_; + + my $scope = $params{scope} or croak "'scope' is required"; + my $service = $params{service} or croak "'service' is required"; + my $settings = $params{settings} or croak "'settings' is required"; + + my $meth = "gen_${service}_${scope}_text"; + + if (my $tm = $self->text_mod($settings)) { + return $tm->$meth(%params, notify => $self) + if $tm->can($meth); + } + + if ($self->can($meth)) { + my $text = $self->$meth(%params); + + my $mod = $settings->notify->text_module; + $text = <<" EOT" if $self->{+TEXT_MOD_FAIL} && $service !~ m/subject/i; +******************************************************************************* +There was an error loading the text generation module '$mod'. +Because of this error the default notification text has been used. + +The error encountered was: +$self->{+TEXT_MOD_FAIL} +******************************************************************************* + +$text + EOT + + return $text; + } + + confess "No notification text method '$meth'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::Notify - Plugin to send email and/or slack notifications + +=head1 DESCRIPTION + +This plugin is used for sending email and/or slack notifications from yath. + +=head1 SYNOPSIS + +=head2 IN A TEST + + #!/usr/bin/perl + use Test2::V0; + # HARNESS-META owner author@example.com + # HARNESS-META slack #slack_channel + # HARNESS-META slack #slack_user + +You can use the C<# HARNESS-META owner EMAIL_ADDRESS> to specify an "owner" +email address. You can use the C<# HARNESS-META slack USER/CHANNEL> to specify +a slack user or channel that owns the test. + +=head2 RUNNING WITH NOTIFICATIONS ENABLED + + $ yath test -pNotify ... + +Also of note, most of the time you can just specify the notification options +you want and the plugin will load as needed as long as C<--no-scan-plugins> was +not specified. + +=head3 EMAIL + + $ yath test --notify-email-owner --notify-email-from user@example.com --notify-email-fail fixer@example.com + +=head3 SLACK + +A slack hooks url is always needed for slack to work. + + $ yath test --notify-slack-url https://hooks.slack.com/... --notify-slack-fail '#foo' --notify-slack-owner + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin/SysInfo.pm b/liby/App/Yath/Plugin/SysInfo.pm new file mode 100644 index 000000000..56eebd2e4 --- /dev/null +++ b/liby/App/Yath/Plugin/SysInfo.pm @@ -0,0 +1,115 @@ +package App::Yath::Plugin::SysInfo; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Sys::Hostname qw/hostname/; +use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS/; +use Config qw/%Config/; + +use parent 'App::Yath::Plugin'; +use Test2::Harness::Util::HashBase qw/-host_short_pattern/; + +sub inject_run_data { + my $self = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + my %data = ( + env => { + user => $ENV{USER}, + shell => $ENV{SHELL}, + term => $ENV{TERM}, + }, + + ipc => { + can_fork => CAN_FORK(), + can_really_fork => CAN_REALLY_FORK(), + can_thread => CAN_THREAD(), + can_sigsys => CAN_SIGSYS(), + }, + ); + + my ($short, $raw) = ('sys', 'system info'); + + if (my $hostname = hostname()) { + $short = undef; + $data{hostname} = $hostname; + $raw = $hostname; + + if (my $pattern = $self->{+HOST_SHORT_PATTERN}) { + if ($hostname =~ /($pattern)/) { + $short = $1; + } + } + + unless ($short) { + $short = $hostname; + $short =~ s/\.[^\.]*$// while length($short) > 18 && $short =~ m/\./; + } + } + + my @fields = qw/uselongdouble use64bitall version use64bitint usemultiplicity osname useperlio useithreads archname/; + @{$data{config}}{@fields} = @Config{@fields}; + + push @$fields => { + name => 'sys', + details => $short, + raw => $raw, + data => \%data, + }; +} + +sub TO_JSON { ref($_[0]) } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::SysInfo - Plugin to attach system information to a run. + +=head1 DESCRIPTION + +This plugin attaches a lot of system information to the yath log. This is +mainly useful if you intend to view the log in L<Test2::Harness::UI>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Plugin/YathUI.pm b/liby/App/Yath/Plugin/YathUI.pm new file mode 100644 index 000000000..2dd3bea7a --- /dev/null +++ b/liby/App/Yath/Plugin/YathUI.pm @@ -0,0 +1,362 @@ +package App::Yath::Plugin::YathUI; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Test2::Harness::Util qw/read_file mod2file looks_like_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use App::Yath::Options; +use parent 'App::Yath::Plugin'; + +sub can_log { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Logging'}; + return 0; +} + +sub can_finder { + my ($option, $options) = @_; + + return 1 if $options->included->{'App::Yath::Options::Finder'}; + return 0; +} + +option_group {prefix => 'yathui', category => "YathUI Options"} => sub { + option url => ( + type => 's', + alt => ['uri'], + description => "Yath-UI url", + long_examples => [" http://my-yath-ui.com/..."], + ); + + option api_key => ( + type => 's', + description => "Yath-UI API key. This is not necessary if your Yath-UI instance is set to single-user" + ); + + option project => ( + type => 's', + description => "The Yath-UI project for your test results", + ); + + option mode => ( + type => 's', + default => 'qvfd', + description => "Set the upload mode (default 'qvfd')", + long_examples => [ + ' summary', + ' qvf', + ' qvfd', + ' complete', + ], + ); + + option retry => ( + type => 'c', + description => "How many times to try an operation before giving up", + default => 0, + ); + + option grace => ( + description => "If yath cannot connect to yath-ui it normally throws an error, use this to make it fail gracefully. You get a warning, but things keep going.", + default => 0, + ); + + option durations => ( + description => "Poll duration data from Yath-UI to help order tests efficiently", + default => 0, + applicable => \&can_finder, + ); + + option coverage => ( + description => "Poll coverage data from Yath-UI to determine what tests should be run for changed files", + default => 0, + applicable => \&can_finder, + ); + +# TODO +# option median_durations => ( +# type => 'b', +# description => "Get median duration data", +# default => 0, +# ); + + option medium_duration => ( + type => 's', + description => "Minimum duration length (seconds) before a test goes from SHORT to MEDIUM", + long_examples => [' 5'], + default => 5, + ); + + option long_duration => ( + type => 's', + description => "Minimum duration length (seconds) before a test goes from MEDIUM to LONG", + long_examples => [' 10'], + default => 10, + ); + + option upload => ( + description => "Upload the log to Yath-UI", + default => 0, + applicable => \&can_log, + ); + + post -1 => sub { + my %params = @_; + + my $settings = $params{settings}; + my $options = $params{options}; + + my $has_finder = $options->included->{'App::Yath::Options::Finder'}; + my $has_logger = $options->included->{'App::Yath::Options::Logging'}; + + my $has_durations = $has_finder && $settings->yathui->durations; + my $has_upload = $has_logger && $settings->yathui->upload; + my $has_coverage = $has_finder && $settings->yathui->coverage; + + return unless $has_durations || $has_upload || $has_coverage; + + my $url = $settings->yathui->url or die "'--yathui-url URL' is required to use durations, coverage, or upload a log"; + my $project = $settings->yathui->project or die "'--yathui-project NAME' is required to use durations, coverage, or upload a log"; + my $grace = $settings->yathui->grace; + + $url =~ s{/+$}{}g; + + if ($has_upload) { + $settings->logging->field(log => 1); + $settings->logging->field(bzip2 => 1); + } + + if ($has_coverage) { + my $curl = join '/' => ($url, 'coverage', $project); + $settings->cover->field(($grace ? 'maybe_from' : 'from'), $curl); + } + + if ($has_durations) { + my $med = $settings->yathui->medium_duration; + my $long = $settings->yathui->long_duration; + + my $durl = join '/' => ($url, 'durations', $project, $med, $long); + $settings->finder->field(($grace ? 'maybe_durations' : 'durations'), $durl); + } + + return; + }; +}; + +sub grab_rerun { + my $this = shift; + my ($rerun, %params) = @_; + + return (0) if $rerun =~ m/\.jsonl(\.gz|\.bz2)?/; + + my $settings = $params{settings}; + my $mode_hash = $params{mode_hash}; + + my $path; + if ($rerun eq '1') { + my $project = $settings->yathui->project or return (0); + my $user = $settings->yathui->user // $ENV{USER}; + + $path = "$project/$user"; + + print "Re-run requested with no paremeters, ${ \__PACKAGE__ } querying YathUI (web request) for last run matching $path...\n"; + + # API Qwerk :-/ + $path .= '/0'; + } + elsif (looks_like_uuid($rerun)) { + $path = "$rerun"; + print "Re-run requested with UUID, ${ \__PACKAGE__ } querying YathUI (web request) for matching run, or latest run from project or user matching the UUID\n"; + } + else { + return (0); + } + + $path = "rerun/$path"; + + my ($ok, $res, $data) = $this->_request($settings, $path, {json => 1}); + + if (!$ok) { + print "Error getting a re-run data from yathui: $data...\n"; + return (1); + } + + return (1, $data); +} + +sub _request { + my $this = shift; + my ($settings, $path, $payload) = @_; + + my $url = $settings->yathui->url; + $url =~ s{/+$}{}g; + $url = join "/" => ($url, $path); + + my %fields; + + for my $field (qw/project api_key mode/) { + my $val = $settings->yathui->field($field) or next; + $fields{$field} = $val; + } + + require HTTP::Tiny; + eval { require HTTP::Tiny::Multipart; 1 } or die "To use --yathui-* you must install HTTP::Tiny::Multipart.\n"; + + my $res; + for (0 .. $settings->yathui->retry) { + my $http = HTTP::Tiny->new; + $res = $http->post_multipart( + $url => { + headers => {'Content-Type' => 'application/json'}, + %fields, + %$payload, + }, + ); + + next unless $res; + last if $res->{status} eq '200'; + } + + my ($ok, $msg); + if ($res && $res->{status} eq '200') { + my $data; + $ok = eval { $data = decode_json($res->{content}); 1 }; + if ($ok) { + return (1, $res, $data); + } + else { + $msg = $@; + } + } + else { + if ($res) { + $msg = "Server responded with " . $res->{status} . ":\n" . ($res->{content} // 'NO CONTENT'); + } + else { + $msg = "Failed to upload yathui log, no response object"; + } + } + + return (0, $res, $msg); +} + +sub finish { + my $this = shift; + my %params = @_; + + my $settings = $params{settings}; + + return unless $settings->yathui->upload; + + my $log_file = $settings->logging->log_file; + my ($filename) = reverse File::Spec->splitpath($log_file); + + my ($ok, $res, $data) = $this->_request( + 'upload', { + log_file => { + filename => $filename, + content => read_file($log_file, no_decompress => 1), + content_type => 'application/x-bzip2', + }, + + action => 'Upload Log', + json => 1, + } + ); + + die "Error connecting to YathUI: $data\n" + unless $ok; + + my $msg; + if ($data->{errors} && @{$data->{errors}}) { + $ok = 0; + $msg = join "\n" => (@{$data->{errors}}); + } + elsif ($data->{messages}) { + $ok = 1; + + my $url = $settings->yathui->url; + $url =~ s{/+$}{}g; + + $msg = join "\n" => ( + @{$data->{messages}}, + $data->{run_id} ? ("YathUI run url: " . join '/' => ($url, 'run', $data->{run_id})) : (), + ); + } + else { + $ok = 0; + $msg = "No messages recieved"; + } + + chomp($msg); + $msg = "YathUI Upload: $msg"; + if ($ok) { + print "\n$msg\n"; + } + else { + if ($settings->yathui->grace) { + warn $msg; + } + else { + die $msg; + } + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Plugin::YathUI - Plugin to interact with a YathUI server + +=head1 DESCRIPTION + +If you have a Yath-UI L<Test2::Harness::UI> server, you can use this module to +have yath automatically upload logs or retrieve durations data + +=head1 PROVIDED OPTIONS POD IS AUTO-GENERATED + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Tester.pm b/liby/App/Yath/Tester.pm new file mode 100644 index 000000000..33045c4bc --- /dev/null +++ b/liby/App/Yath/Tester.pm @@ -0,0 +1,451 @@ +package App::Yath::Tester; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::API qw/context run_subtest/; +use Test2::Tools::Compare qw/is/; + +use Carp qw/croak/; +use File::Spec; +use File::Temp qw/tempfile tempdir/; +use POSIX; +use Fcntl qw/SEEK_CUR/; + +use App::Yath::Util qw/find_yath/; +use Test2::Harness::Util qw/clean_path apply_encoding/; +use Test2::Harness::Util::IPC qw/run_cmd/; +use Test2::Harness::Util::File::JSONL; + +use Importer Importer => 'import'; +our @EXPORT = qw/yath make_example_dir/; + +my $pdir = tempdir(CLEANUP => 1); + +require App::Yath; +my $apppath = App::Yath->app_path; + +sub cover { + return unless $ENV{T2_DEVEL_COVER}; + $ENV{T2_COVER_SELF} = 1; + return '-MDevel::Cover=-silent,1,+ignore,^t/,+ignore,^t2/,+ignore,^xt,+ignore,^test.pl'; +} + +sub yath { + my %params = @_; + + my $ctx = context(); + + my $cmd = delete $params{cmd} // delete $params{command}; + my $cli = delete $params{cli} // delete $params{args} // []; + my $pre = delete $params{pre} // delete $params{pre_command} // []; + my $env = delete $params{env} // {}; + my $enc = delete $params{encoding}; + my $prefix = delete $params{prefix}; + + my $subtest = delete $params{test} // delete $params{tests} // delete $params{subtest}; + my $exittest = delete $params{exit}; + + my $debug = delete $params{debug} // 0; + my $inc = delete $params{inc} // 1; + my $capture = delete $params{capture} // 1; + my $log = delete $params{log} // 0; + + my $no_app_path = delete $params{no_app_path}; + my $lib = delete $params{lib} // []; + + if (keys %params) { + croak "Unexpected parameters: " . join (', ', sort keys %params); + } + + my (@inc, @dev); + if ($inc) { + my ($pkg, $file) = caller(); + my $dir = $file; + $dir =~ s/\.t2?$//g; + + my $inc = File::Spec->catdir($dir, 'lib'); + push @dev => "-D$inc" if -d $inc; + } + + my ($wh, $cfile); + if ($capture) { + ($wh, $cfile) = tempfile("yath-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.out'); + $wh->autoflush(1); + } + + my (@log, $logfile); + if ($log) { + my $fh; + ($fh, $logfile) = tempfile("yathlog-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.jsonl'); + close($fh); + @log = ('-F' => $logfile); + print "DEBUG: log file = '$logfile'\n" if $debug; + } + + unless ($no_app_path) { + push @inc => "-I$apppath" if $cmd =~ m/^(test|start|projects)$/; + push @dev => "-D$apppath"; + } + + my @cover = cover(); + + my $yath = find_yath; + my @cmd = ($^X, @$lib, @cover, $yath, @$pre, @dev, $cmd ? ($cmd) : (), @inc, @log, @$cli); + + print "DEBUG: Command = " . join(' ' => @cmd) . "\n" if $debug; + + local %ENV = %ENV; + $ENV{YATH_PERSISTENCE_DIR} = $pdir; + $ENV{YATH_CMD} = $cmd; + $ENV{NESTED_YATH} = 1; + $ENV{'YATH_SELF_TEST'} = 1; + $ENV{$_} = $env->{$_} for keys %$env; + my $pid = run_cmd( + no_set_pgrp => 1, + $capture ? (stderr => $wh, stdout => $wh) : (), + command => \@cmd, + run_in_parent => [sub { close($wh) }], + ); + + my (@lines, $exit); + if ($capture) { + open(my $rh, '<', $cfile) or die "Could not open output file: $!"; + apply_encoding($rh, $enc) if $enc; + $rh->blocking(0); + while (1) { + seek($rh, 0, SEEK_CUR); # CLEAR EOF + my @new = <$rh>; + push @lines => @new; + print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; + + waitpid($pid, WNOHANG) or next; + $exit = $?; + last; + } + + while (my @new = <$rh>) { + push @lines => @new; + print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; + } + } + else { + print "DEBUG: Waiting for $pid\n" if $debug; + waitpid($pid, 0); + $exit = $?; + } + + print "DEBUG: Exit: $exit\n" if $debug; + + my $out = { + exit => $exit, + $capture ? (output => join('', @lines)) : (), + $log ? (log => Test2::Harness::Util::File::JSONL->new(name => $logfile)) : (), + }; + + my $name = join(' ', map { length($_) < 30 ? $_ : substr($_, 0, 10) . "[...]" . substr($_, -10) } grep { defined($_) } $prefix, 'yath', @$pre, $cmd ? ($cmd) : (), @$cli); + run_subtest( + $name, + sub { + if (defined $exittest) { + my $ictx = context(level => 3); + is($exit, $exittest, "Exit Value Check"); + $ictx->release; + } + + if ($subtest) { + local $_ = $out->{output}; + local $? = $out->{exit}; + $subtest->($out); + } + + my $ictx = context(level => 3); + + $ictx->diag("Command = " . join(' ' => grep { defined $_ } @cmd) . "\nExit = $exit\n==== Output ====\n$out->{output}\n========") + unless $ictx->hub->is_passing; + + $ictx->release; + }, + {buffered => 1}, + $out, + ) if $subtest || defined $exittest; + + $ctx->release; + + return $out; +} + +sub _gen_passing_test { + my ($dir, $subdir, $file) = @_; + + my $path = File::Spec->catdir($dir, $subdir); + my $full = File::Spec->catfile($path, $file); + + mkdir($path) or die "Could not make $subdir subdir: $!" + unless -d $path; + + open(my $fh, '>', $full); + print $fh "use Test2::Tools::Tiny;\nok(1, 'a passing test');\ndone_testing\n"; + close($fh); + + return $full; +} + +sub make_example_dir { + my $dir = tempdir(CLEANUP => 1, TMP => 1); + + _gen_passing_test($dir, 't', 'test.t'); + _gen_passing_test($dir, 't2', 't2_test.t'); + _gen_passing_test($dir, 'xt', 'xt_test.t'); + + return $dir; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Tester - Tools for testing yath + +=head1 DESCRIPTION + +This package provides utilities for running yath from within tests to verify +its behavior. This is primarily used for integration testing of yath and for +third party components. + +=head1 SYNOPSIS + + use App::Yath::Tester qw/yath/; + + my $result = yath( + # Command and arguments + command => 'test', + args => ['-pMyPlugin', 'path/to/test', ...], + + # Exit code we expect from yath + exit => 0, + + # Subtest to verify results + test => sub { + my $result = shift; + + # Redundant since we have the exit check above + is($result->{exit}, 0, "Verify exit"); + + is($result->{output}, $expected_output, "Got the expected output from yath"); + }, + ); + +=head1 EXPORTS + +There are 2 exports from this module. + +=head2 $result = yath(...) + + my $result = yath( + # Command and arguments + command => 'test', + args => ['-pMyPlugin', 'path/to/test', ...], + + # Exit code we expect from yath + exit => 0, + + # Subtest to verify results + test => sub { + my $result = shift; + + # Redundant since we have the exit check above + is($result->{exit}, 0, "Verify exit"); + + is($result->{output}, $expected_output, "Got the expected output from yath"); + }, + ); + +=head3 ARGUMENTS + +=over 4 + +=item cmd => $command + +=item command => $command + +Either 'cmd' or 'command' can be used. This argument takes a string that should +be a command name. + +=item cli => \@ARGS + +=item args => \@ARGS + +Either 'cli' or 'args' can be used. If none are provided an empty arrayref is +used. This argument takes an arrayref of arguments to the yath command. + + $ yath [PRE_COMMAND] [COMMAND] [ARGS] + +=item pre => \@ARGS + +=item pre_command => \@ARGS + +Either 'pre' or 'pre_command' can be used. An empty arrayref is used if none +are provided. These are arguments provided to yath BEFORE the command on the +command line. + + $ yath [PRE_COMMAND] [COMMAND] [ARGS] + +=item env => \%ENV + +Provide custom environment variable values to set before running the yath +command. + +=item encoding => $encoding_name + +If you expect your yath command's output to be in a specific encoding you can +specify it here to make sure the C<< $result->{output} >> text has been read +properly. + +=item test => sub { ... } + +=item tests => sub { ... } + +=item subtest => sub { ... } + +These 3 arguments are all aliases for the same thing, only one should be used. +The codeblock will be called with C<$result> as the onyl argument. The +codeblock will be run as a subtest. If you specify the C<'exit'> argument that +check will also happen in the same subtest. + + test => sub { + my $result = shift; + + ... verify result ... + }, + +=item exit => $integer + +Verify that the yath command exited with the specified exit code. This check +will be run in a subtest. If you specify a custom subtest then this check will +appear to come from that subtest. + +=item debug => $integer + +Output debug info in realtime, depending on the $integer value this may include +the output from the yath command being run. + + 0 - No debugging + 1 - Output the command and other action being taken by the tool + 2 - Echo yath output as it happens + +=item inc => $bool + +This defaults to true. + +When true the tool will look for a directory next to your test file with an +identical name except that '.t' or '.t2' will be stripped from it. If that +directory exists it will be added as a dev-lib to the yath command. + +If your test file is 't/foo/bar.t' then your yath command will look like this: + + $ yath -D=t/foo/bar [PRE-COMMAND] [COMMAND] [ARGS] + +=item capture => $bool + +Defaults to true. + +When true the yath output will be captured and put into +C<< $result->{output} >>. + +=item log => $bool + +Defaults to false. + +When true yath will be instructed to produce a log, the log will be accessible +via C<< $result->{log} >>. C<< $result->{log} >> will be an instance of +L<Test2::Harness::Util::File::JSONL>. + +=item no_app_path => $bool + +Default to false. + +Normally C<< -D=/path/to/lib >> is added to the yath command where +C<'/path/to/lib'> is the path the the lib dir L<App::Yath> was loaded from. +This normally insures the correct version of yath libraries is loaded. + +When this argument is set to true the path is not added. + +=item lib => [...] + +This poorly named argument allows you to inject command line argumentes between +C<perl> and C<yath> in the command. + + perl [LIB] path/to/yath [PRE-COMMAND] [COMMAND] [ARGS] + +=back + +=head3 RESULT + +The result hashref may containt he following fields depending on the arguments +passed into C<yath()>. + +=over 4 + +=item exit => $integer + +Exit value returned from yath. + +=item output => $string + +The output produced by the yath command. + +=item log => $jsonl_object + +An instance of L<Test2::Harness::Util::File::JSONL> opened from the log file +produced by the yath command. + +B<Note:> By default no logging is done, you must specify the C<< log => 1 >> +argument to enable it. + +=back + +=head2 $path = make_example_dir() + +This will create a temporary directory with 't', 't2', and 'xt' subdirectories +each of which will contain a single passing test. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/App/Yath/Util.pm b/liby/App/Yath/Util.pm new file mode 100644 index 000000000..9d0a96ca1 --- /dev/null +++ b/liby/App/Yath/Util.pm @@ -0,0 +1,369 @@ +package App::Yath::Util; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Sys::Hostname qw/hostname/; + +use Test2::Harness::Util qw/clean_path/; +use Test2::Harness::Util::File::JSON; + +use Cwd qw/realpath/; +use Importer Importer => 'import'; +use Config qw/%Config/; +use Carp qw/croak/; + +our @EXPORT_OK = qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath +}; + +sub find_yath { + return $App::Yath::Script::SCRIPT if defined $App::Yath::Script::SCRIPT; + + if (-d 'scripts') { + my $script = File::Spec->catfile('scripts', 'yath'); + return $App::Yath::Script::SCRIPT = clean_path($script) if -e $script && -x $script; + } + + my @keys = qw{ + bin binexp initialinstalllocation installbin installscript + installsitebin installsitescript installusrbinperl installvendorbin + scriptdir scriptdirexp sitebin sitebinexp sitescript sitescriptexp + vendorbin vendorbinexp + }; + + my %seen; + for my $path (@Config{@keys}) { + next unless $path; + next if $seen{$path}++; + + my $script = File::Spec->catfile($path, 'yath'); + next unless -f $script && -x $script; + + $App::Yath::Script::SCRIPT = $script = clean_path($script); + return $script; + } + + die "Could not find yath in Config paths"; +} + +sub isolate_stdout { + # Make $fh point at STDOUT, it is our primary output + open(my $fh, '>&', STDOUT) or die "Could not clone STDOUT: $!"; + select $fh; + $| = 1; + + # re-open STDOUT redirected to STDERR + open(STDOUT, '>&', STDERR) or die "Could not redirect STDOUT to STDERR: $!"; + select STDOUT; + $| = 1; + + # Yes, we want to keep STDERR selected + select STDERR; + $| = 1; + + return $fh; +} + +sub is_generated_test_pl { + my ($file) = @_; + + open(my $fh, '<', $file) or die "Could not open '$file': $!"; + + my $count = 0; + while (my $line = <$fh>) { + last if $count++ > 5; + next unless $line =~ m/^# THIS IS A GENERATED YATH RUNNER TEST$/; + return 1; + } + + return 0; +} + + +sub find_in_updir { + my $path = shift; + return clean_path($path) if -f $path; + + my %seen; + while(1) { + $path = File::Spec->catdir('..', $path); + my $check = eval { realpath(File::Spec->rel2abs($path)) }; + last unless $check; + last if $seen{$check}++; + return $check if -f $check; + } + + return; +} + +sub _find_pfile { + my ($settings, %params) = @_; + + croak "Settings is a required argument" unless $settings; + + # First do the entire search without vivify + if ($params{vivify}) { + my $found = find_pfile($settings, %params, vivify => 0); + return $found if $found; + } + + my $yath = $settings->harness; + + if (my $pfile = $yath->persist_file) { + return $pfile if -f $pfile || $params{vivify}; + + return; # Specified, but not found and no vivify + } + + my $basename = "yath-persist.json"; + my $user = $ENV{USER}; + my $hostname = hostname(); + my $project = $yath->project; + + my @names = ($basename); + @names = (@names, map { "$project-$_" } @names) if $project; + @names = (@names, map { "$hostname-$_" } @names) if $hostname; + @names = (@names, map { "$user-$_" } @names) if $user; + @names = reverse map { ".$_" } @names; + + my $set_dir = $yath->persist_dir // $ENV{YATH_PERSISTENCE_DIR}; + my $dir = $set_dir // $ENV{TMPDIR} // $ENV{TEMPDIR} // File::Spec->tmpdir; + + # If a dir was specified, or if the current dir is not writable then we must use $dir/$name + if ($project || $set_dir || !-w '.') { + for my $name (@names) { + my $pfile = clean_path(File::Spec->catfile($dir, $name)); + return $pfile if -f $pfile; + } + + return clean_path(File::Spec->catfile($dir, $names[0])) if $params{vivify}; + return; # Not found + } + + # Fall back to using the current dir (which must be writable) + for my $name (@names) { + my $pfile = find_in_updir($name); + return $pfile if $pfile && -f $pfile; + } + + # Creating it here! + return clean_path(File::Spec->catfile('.', $names[0])) if $params{vivify}; + + # Nope, nothing. + return; +} + +sub fit_to_width { + my ($width, $join, $text) = @_; + + my @parts = ref($text) ? @$text : split /\s+/, $text; + + my @out; + + my $line = ""; + for my $part (@parts) { + my $new = $line ? "$line$join$part" : $part; + + if ($line && length($new) > $width) { + push @out => $line; + $line = $part; + } + else { + $line = $new; + } + } + push @out => $line if $line; + + return join "\n" => @out; +} + +my $SEEN_ERROR = 0; +sub find_pfile { + my ($settings, %params) = @_; + my $pfile = _find_pfile($settings, %params) or return; + + return $pfile unless -e $pfile; + return $pfile if $params{no_checks}; + return $pfile if $SEEN_ERROR; + + my $data = Test2::Harness::Util::File::JSON->new(name => $pfile)->read(); + + $data->{version} //= ''; + $data->{hostname} //= ''; + $data->{user} //= ''; + $data->{pid} //= ''; + $data->{dir} //= ''; + + my $hostname = hostname(); + my $user = $ENV{USER}; + + my @bad; + + push @bad => "** Version mismatch, persistent runner is version $data->{version}, current is version $VERSION. **" + if $data->{version} ne $VERSION; + + push @bad => "** Hostname mismatch, persistent runner hostname is '$data->{hostname}', current hostname is '$hostname'. **" + if $data->{hostname} ne $hostname; + + push @bad => "** User mismatch, persistent runner user is '$data->{user}', current user is '$user'. **" + if $data->{user} ne $user; + + push @bad => "** Workdir missing, persistent runner is supposed to be at '$data->{dir}', but it does not exist. **" + unless -d $data->{dir}; + + push @bad => "** PID not running, persistent runner is supposed to be running with PID '$data->{pid}', but it is not. **" + unless kill(0, $data->{pid}); + + return $pfile unless @bad; + + my $break = ('=' x 120) . "\n"; + my $msg = join "\n" => $break, @bad, <<" EOT", $break; + +Errors like this usually indicate that the persistent runner has gone away. +Maybe the system was shut down improperly, or maybe the process was killed too +quickly to clean up after itself. + +Here is the information indicated by the persistence file: + Runner PID: $data->{pid} + Runner Vers: $data->{version} + Runner user: $data->{user} + Runner host: $data->{hostname} + Working dir: $data->{dir} + +If the persistent runner is truly gone you should delete the following file to +continue: + +$pfile + EOT + + $SEEN_ERROR = 1; + die $msg unless $params{no_fatal}; + warn $msg unless $params{no_warn}; + return $pfile; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +App::Yath::Util - General utilities for yath that do not fit anywhere else. + +=head1 DESCRIPTION + +This package exports several tools used throughout yath that did not fit into +any other package. + +=head1 SYNOPSIS + + use App::Yath::Util qw{ + find_pfile + find_in_updir + is_generated_test_pl + fit_to_width + isolate_stdout + find_yath + }; + +=head1 EXPORTS + +Note that nothing is exported by default, you must request each function to +import. + +=over 4 + +=item $path_to_pfile = find_pfile($settings, %params) + +The first argument must be an instance of L<Test2::Harness::Settings>. + +Currently the only supported param is C<vivify>, when set to true the pfile +will be created if one does not already exist. + +The pfile is a file that tells yath that a persistent runner is active, and how +to communicate with it. + +=item $path_to_file = find_in_updir($file_name) + +Look for C<$file_name> in the current directory or any parent directory. + +=item $bool = is_generated_test_pl($path_to_test_file) + +Check if the specified test file was generated by the C<yath init> command. + +=item fit_to_width($width, $join, $text) + +This will split the C<$text> on space, and then recombine it using C<$join> +inserting newlines as necessary in an attempt to fit the text into C<$width> +horizontal characters. If any words are larger than C<$width> they will not be +split and text-wrapping may occur if used for terminal display. + +=item $stdout = isolate_stdout() + +This will close STDOUT and reopen it to point at STDERR. The result of this is +that any print statement that does not specify a fielhandle will print to +STDERR instead of STDOUT, in addition any print directly to STDOUT will instead +go to STDERR. A filehandle to the real STDOUT is returned for you to use when +you actually want to write to STDOUT. + +This is used by some yath processes that need to print structured data to +STDOUT without letting any third part modules they may load write to the real +STDOUT. + +=item $path_to_script = find_yath() + +This will attempt to find the C<yath> command line script. When possible this +will return the path that was used to launch yath. If yath was not run to start +the process it will search the paths specified in the L<Config> module. This +will throw an exception if the script cannot be found. + +Note: The result is cached so that subsequent calls will return the same path +even if something installs a new yath script in another location that would +otherwise be found first. This guarentees that a single process will not switch +scripts. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Formatter/QVF.pm b/liby/Test2/Formatter/QVF.pm new file mode 100644 index 000000000..91a8aae3f --- /dev/null +++ b/liby/Test2/Formatter/QVF.pm @@ -0,0 +1,139 @@ +package Test2::Formatter::QVF; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +BEGIN { require Test2::Formatter::Test2; our @ISA = qw(Test2::Formatter::Test2) } + +use Test2::Util::HashBase qw{ + -job_buffers + -real_verbose +}; + +sub init { + my $self = shift; + $self->SUPER::init(); + + $self->{+REAL_VERBOSE} = $self->{+VERBOSE}; + + $self->{+VERBOSE} ||= 100; +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + + return if $f && $f->{__RENDER__}->{update_active_disp}++; + + $self->SUPER::update_active_disp($f); +} + +sub write { + my ($self, $e, $num, $f) = @_; + + return $self->SUPER::write($e, $num, $f) if $self->{+REAL_VERBOSE}; + + $f ||= $e->facet_data; + + my $job_id = $f->{harness}->{job_id}; + + push @{$self->{+JOB_BUFFERS}->{$job_id}} => [$e, $num, $f] + if $job_id; + + my $show = $self->update_active_disp($f); + + if ($f->{harness_job_end} || !$job_id) { + $show = 1; + + my $buffer = delete $self->{+JOB_BUFFERS}->{$job_id}; + + if($f->{harness_job_end}->{fail}) { + $self->SUPER::write(@{$_}) for @$buffer; + } + else { + $f->{info} = [grep { $_->{tag} ne 'TIME' } @{$f->{info}}] if $f->{info}; + $self->SUPER::write($e, $num, $f) + } + } + + $self->{+ECOUNT}++; + + return unless $self->{+TTY}; + return unless $self->{+PROGRESS}; + + $show ||= 1 unless $self->{+ECOUNT} % 10; + + if ($show) { + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->{+IO}; + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::QVF - Test2 formatter that is [Q]uiet but [V]erbose on +[F]ailure. + +=head1 DESCRIPTION + +This formatter is a subclass of L<Test2::Formatter::Test2>. This one will +buffer all output from a test file and only show it to you if there is a +failure. Most of the time it willonly show you the completion notifications for +each test. + +=head1 SYNOPSIS + + $ yath test --qvf ... + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/liby/Test2/Formatter/Stream.pm b/liby/Test2/Formatter/Stream.pm new file mode 100644 index 000000000..d14999177 --- /dev/null +++ b/liby/Test2/Formatter/Stream.pm @@ -0,0 +1,518 @@ +package Test2::Formatter::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Time::HiRes qw/time/; +use IO::Handle; +use File::Spec(); +use List::Util qw/first/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/JSON JSON_IS_XS/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; + +use Test2::Util qw/get_tid ipc_separator/; + +use parent qw/Test2::Formatter/; +use Test2::Util::HashBase qw/-io _encoding _no_header _no_numbers _no_diag -stream_id -tb -tb_handles -dir -_pid -_tid -_fh <job_id -ugids/; + +BEGIN { + no warnings 'once'; + + if (my $use_pipe = $ENV{T2_HARNESS_USE_ATOMIC_PIPE}) { + require Atomic::Pipe; + *USE_PIPE = sub() { 1 }; + $Test2::Harness::STDOUT_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDOUT); + $Test2::Harness::STDOUT_APIPE->set_mixed_data_mode(); + + if ($use_pipe > 1) { + *USE_PIPE_STDERR = sub() { 1 }; + $Test2::Harness::STDERR_APIPE //= Atomic::Pipe->from_fh('>&=', \*STDERR); + $Test2::Harness::STDERR_APIPE->set_mixed_data_mode(); + } + else { + *USE_PIPE_STDERR = sub() { 0 }; + } + } + else { + *USE_PIPE = sub() { 0 }; + *USE_PIPE_STDERR = sub() { 0 }; + $Test2::Harness::STDOUT_APIPE = undef; + $Test2::Harness::STDERR_APIPE = undef; + } +} + + + +BEGIN { + my $J = JSON->new; + $J->indent(0); + $J->convert_blessed(1); + $J->allow_blessed(1); + $J->utf8(1); + $J->ascii(1); + + require constant; + constant->import(ENCODER => $J); + + if (JSON_IS_XS) { + require JSON::PP; + my $JPP = JSON::PP->new; + $JPP->indent(0); + $JPP->convert_blessed(1); + $JPP->allow_blessed(1); + $JPP->utf8(1); + $JPP->ascii(1); + + constant->import(ENCODER_PP => $JPP); + } +} + +my ($ROOT_TID, $ROOT_PID, $ROOT_DIR, $ROOT_JOB_ID, $ROOT_UGIDS); +sub import { + my $class = shift; + my %params = @_; + + confess "$class no longer accept the 'file' argument, it now takes a 'dir' argument" + if exists $params{file}; + + $class->SUPER::import(); + + $ROOT_PID = $$; + $ROOT_TID = get_tid(); + $ROOT_DIR = $params{dir} if $params{dir}; + $ROOT_JOB_ID = $params{job_id} if $params{job_id}; + $ROOT_UGIDS = [$<, $>, $(, $)]; + + if ($ROOT_DIR && ! -d $ROOT_DIR) { + mkdir($ROOT_DIR) or die "Could not make root dir: $!"; + } +} + +sub hide_buffered { 0 } + +sub fh { + my $self = shift; + + my $dir = $self->{+DIR} or return undef; + + my $pid = $self->{+_PID}; + my $tid = $self->{+_TID}; + + if ($pid && $pid != $$) { + delete $self->{+_PID}; + delete $self->{+_FH}; + } + + if ($tid && $tid != get_tid()) { + delete $self->{+_TID}; + delete $self->{+_FH}; + } + + return $self->{+_FH} if $self->{+_FH}; + + $self->{+STREAM_ID} = 1; + + $pid = $self->{+_PID} = $$; + $tid = $self->{+_TID} = get_tid(); + + my $file = File::Spec->catfile($dir, join(ipc_separator() => 'events', $pid, $tid) . ".jsonl"); + + my @now = ($<, $>, $(, $)); + local ($<, $>, $(, $)) = @{$self->{+UGIDS}} if $self->{+UGIDS} && first { $self->{+UGIDS}->[$_] ne $now[$_] } 0 .. $#now; + + mkdir($dir) or die "Could not make dir '$dir': $!" unless -d $dir; + confess "File '$file' already exists!" if -f $file; + open(my $fh, '>', $file) or die "Could not open file: $file"; + $fh->autoflush(1); + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + return $self->{+_FH} = $fh; +} + +sub init { + my $self = shift; + + $self->{+STREAM_ID} = 1; + $self->{+UGIDS} //= [$<, $>, $(, $)]; + + # To create necessary directories as soon as possible + $self->fh(); + + for (@{$self->{+IO}}) { + $_->autoflush(1); + } + + STDOUT->autoflush(1); + STDERR->autoflush(1); + + if ($INC{'Test2/API.pm'}) { + Test2::API::test2_stdout()->autoflush(1); + Test2::API::test2_stderr()->autoflush(1); + } + + if ($self->{check_tb}) { + require Test::Builder::Formatter; + $self->{+TB} = Test::Builder::Formatter->new(); + $self->{+TB_HANDLES} = [@{$self->{+TB}->handles}]; + } +} + +sub new_root { + my $class = shift; + my %params = @_; + + $ROOT_PID = $$ unless defined $ROOT_PID; + $ROOT_TID = get_tid() unless defined $ROOT_TID; + + confess "new_root called from child process!" + if $ROOT_PID != $$; + + confess "new_root called from child thread!" + if $ROOT_TID != get_tid(); + + require Test2::API; + my $io = $params{+IO} = [Test2::API::test2_stdout(), Test2::API::test2_stderr()]; + $_->autoflush(1) for @$io; + + confess "T2_STREAM_FILE is no longer used, see T2_STREAM_DIR" + if exists $ENV{T2_STREAM_FILE}; + + $params{+DIR} ||= $ENV{T2_STREAM_DIR} || $ROOT_DIR; + $params{+JOB_ID} ||= $ENV{T2_STREAM_JOB_ID} || $ROOT_JOB_ID || 1; + + # DO NOT REOPEN THEM! + delete $ENV{T2_FORMATTER} if $ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} eq 'Stream'; + delete $ENV{T2_STREAM_DIR}; + delete $ENV{T2_STREAM_JOB_ID}; + $ROOT_DIR = undef; + + $params{check_tb} = 1 if $INC{'Test/Builder.pm'}; + + $params{+UGIDS} = $ROOT_UGIDS if $ROOT_UGIDS; + + return $class->new(%params); +} + +sub record { + my $self = shift; + my ($facets, $num) = @_; + + my $stamp = time; + my $times = [times]; + + my @sync = @{$self->{+IO}}; + my $leader = 0; + + my $fh = $self->fh; + unless($fh) { + $leader = 1; + $fh = shift @sync; + } + + if ($facets->{control}->{halt}) { + my $reason = $facets->{control}->{details} || ""; + + if ($leader) { + print $fh "\nBail out! $reason\n"; + } + else { + open(my $bh, '>', File::Spec->catfile($self->{+DIR}, 'bail')) or die "Could not create bail file: $!"; + print $bh $reason; + close($bh); + } + } + + my $tid = get_tid(); + my $id = $self->{+STREAM_ID}++; + my $event_id = $facets->{about}->{uuid} ||= gen_uuid(); + + my $json; + { + no warnings 'once'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + + if (JSON_IS_XS) { + for my $encoder (ENCODER, ENCODER_PP) { + local $@; + my $ok = eval { + $json = $encoder->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + 1; + }; + my $err = $@; + last if $ok; + + # Intercept bug in JSON::XS so we can fall back to JSON::PP + next if $encoder eq ENCODER && $err =~ m/Modification of a read-only value attempted/; + + # Different error, time to die. + die $err; + } + } + else { + $json = ENCODER->encode( + { + stamp => $stamp, + times => $times, + stream_id => $id, + tid => $tid, + pid => $$, + event_id => $event_id, + facet_data => $facets, + assert_count => $self->{+_NO_NUMBERS} ? undef : $num, + } + ); + } + } + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $job_id = $self->{+JOB_ID}; + + if (USE_PIPE) { + $Test2::Harness::STDOUT_APIPE->write_message($json); + $Test2::Harness::STDERR_APIPE->write_message(qq/{"event_id":"$event_id"}/) if USE_PIPE_STDERR; + } + else { + print $fh $leader ? ("T2-HARNESS-$job_id-EVENT: ", $json, "\n") : ($json, "\n"); + print $_ "T2-HARNESS-$job_id-ESYNC: ", join(ipc_separator() => $$, $tid, $id) . "\n" for @sync; + } +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + $self->record({control => {encoding => $enc}}); + $self->_set_encoding($enc); + $self->{+TB}->encoding($enc) if $self->{+TB}; + } + + return $self->{+_ENCODING}; +} + +sub _set_encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + + # Do not apply encoding to the UTF8 output, we let the utf8 formatter + # handle that. This means do not apply encoding to $self->{+_FH}. + + apply_encoding(\*STDOUT, $enc); + apply_encoding(\*STDERR, $enc); + + if (!USE_PIPE) { + my $job_id = $self->{+JOB_ID}; + for my $fh (@{$self->{+IO}}) { + print $fh "T2-HARNESS-$job_id-ENCODING: $enc\n"; + apply_encoding($fh, $enc); + } + } + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub { }; +} + +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + $self->_set_encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + # Hide these if we must, but do not remove them for good. + local $f->{info} if $self->{+_NO_DIAG}; + local $f->{plan} if $self->{+_NO_HEADER}; + + my $tb_only = 0; + if ($self->{+TB}) { + $tb_only ||= $self->{+TB_HANDLES}->[0] != $self->{+TB}->{handles}->[0]; + $tb_only ||= $self->{+TB_HANDLES}->[1] != $self->{+TB}->{handles}->[1]; + + my $todo_match = $self->{+TB_HANDLES}->[0] == $self->{+TB}->{handles}->[2] + || $self->{+TB_HANDLES}->[1] == $self->{+TB}->{handles}->[2]; + + $tb_only ||= !$todo_match; + + if ($tb_only) { + my $buffered = hub_truth($f)->{buffered}; + $self->{+TB}->write($e, $num, $f) if $self->{+TB} && !$buffered; + return; + } + } + + $self->record($f, $num); +} + +sub no_header { $_[0]->{+_NO_HEADER} } +sub no_diag { $_[0]->{+_NO_DIAG} } +sub no_numbers { $_[0]->{+_NO_NUMBERS} } + +sub handles { + my $self = shift; + + return $self->{+TB}->handles if $self->{+TB}; + return; +} + +sub set_no_header { + my $self = shift; + ($self->{+_NO_HEADER}) = @_; + $self->{+TB}->set_no_header(@_) if $self->{+TB}; + $self->{+_NO_HEADER}; +} + +sub set_no_diag { + my $self = shift; + ($self->{+_NO_DIAG}) = @_; + $self->{+TB}->set_no_diag(@_) if $self->{+TB}; + $self->{+_NO_DIAG}; +} + +sub set_no_numbers { + my $self = shift; + ($self->{+_NO_NUMBERS}) = @_; + $self->{+TB}->set_no_numbers(@_) if $self->{+TB}; + $self->{+_NO_NUMBERS}; +} + +sub set_handles { + my $self = shift; + return $self->{+TB}->set_handles(@_) if $self->{+TB}; + return; +} + +sub terminate { + my $self = shift; + return $self->SUPER::terminate(@_) unless $self->{+TB}; + return $self->{+TB}->terminate(@_); +} + +sub finalize { + my $self = shift; + return $self->SUPER::finalize(@_) unless $self->{+TB}; + return $self->{+TB}->finalize(@_); +} + +sub DESTROY {} + +our $AUTOLOAD; + +sub AUTOLOAD { + my $this = shift; + + my $meth = $AUTOLOAD; + $meth =~ s/^.*:://g; + + my $type = ref($this); + + return $this->{+TB}->$meth(@_) + if $type && $this->{+TB} && $this->{+TB}->can($meth); + + $type ||= $this; + croak qq{Can't locate object method "$meth" via package "$type"}; +} + +sub isa { + my $in = shift; + return $in->SUPER::isa(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::isa(@_) || $in->{+TB}->isa(@_); +} + +sub can { + my $in = shift; + return $in->SUPER::can(@_) unless ref($in) && $in->{+TB}; + return $in->SUPER::can(@_) || $in->{+TB}->can(@_); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Stream - Test2 Formatter that directly writes events. + +=head1 DESCRIPTION + +This formatter writes all test2 events to event files (one per process/thread) +instead of writing them to STDERR/STDOUT. It will output synchronization +messages to STDERR/STDOUT every time an event is written. From this data the +test output can be properly reconstructed in order with STDERR/STDOUT and +events mostly synced so that they appear in the correct order. + +This formatter is not usually useful to humans. This formatter is used by +L<Test2::Harness> when possible to prevent the loss of data that normally +occurs when TAP is used. + +=head1 SYNOPSIS + +If you really want your test to output this: + + use Test2::Formatter::Stream; + use Test2::V0; + ... + +Otherwise just use L<App::Yath> without the C<--no-stream> argument and this +formatter will be used when possible. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Formatter/Test2.pm b/liby/Test2/Formatter/Test2.pm new file mode 100644 index 000000000..c2d44fa85 --- /dev/null +++ b/liby/Test2/Formatter/Test2.pm @@ -0,0 +1,804 @@ +package Test2::Formatter::Test2; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util::Term qw/term_size/; +use Test2::Harness::Util qw/hub_truth apply_encoding/; +use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; +use Test2::Util qw/IS_WIN32 clone_io/; +use Time::HiRes qw/time/; +use IO::Handle; + +use File::Spec(); +use Test2::Formatter::Test2::Composer; + +use parent 'Test2::Formatter'; + +sub import { + my $class = shift; + return if $ENV{HARNESS_ACTIVE}; + $class->SUPER::import; +} + +use Test2::Util::HashBase qw{ + -composer + -last_depth + -_buffered + <job_io + +io + <enc_io + -_encoding + -show_buffer + -color + -progress + -tty + -no_wrap + -verbose + -job_length + -ecount + -job_colors + -active_files + -_active_disp + -_file_stats + -job_names + -is_persistent + -interactive +}; + +sub TAG_WIDTH() { 8 } + +sub hide_buffered() { 0 } + +sub DEFAULT_TAG_COLOR() { + return ( + 'DEBUG' => Term::ANSIColor::color('red'), + 'DIAG' => Term::ANSIColor::color('yellow'), + 'ERROR' => Term::ANSIColor::color('red'), + 'FATAL' => Term::ANSIColor::color('bold red'), + 'FAIL' => Term::ANSIColor::color('red'), + 'HALT' => Term::ANSIColor::color('bold red'), + 'PASS' => Term::ANSIColor::color('green'), + '! PASS !' => Term::ANSIColor::color('cyan'), + 'TODO' => Term::ANSIColor::color('cyan'), + 'NO PLAN' => Term::ANSIColor::color('yellow'), + 'SKIP' => Term::ANSIColor::color('bold cyan'), + 'SKIP ALL' => Term::ANSIColor::color('bold white on_blue'), + 'STDERR' => Term::ANSIColor::color('yellow'), + 'RUN INFO' => Term::ANSIColor::color('bold bright_blue'), + 'JOB INFO' => Term::ANSIColor::color('bold bright_blue'), + 'LAUNCH' => Term::ANSIColor::color('bold bright_white'), + 'RETRY' => Term::ANSIColor::color('bold bright_white'), + 'PASSED' => Term::ANSIColor::color('bold bright_green'), + 'TO RETRY' => Term::ANSIColor::color('bold bright_yellow'), + 'FAILED' => Term::ANSIColor::color('bold bright_red'), + 'REASON' => Term::ANSIColor::color('magenta'), + 'TIMEOUT' => Term::ANSIColor::color('magenta'), + 'TIME' => Term::ANSIColor::color('blue'), + 'MEMORY' => Term::ANSIColor::color('blue'), + ); +} + +sub DEFAULT_FACET_COLOR() { + return ( + time => Term::ANSIColor::color('blue'), + memory => Term::ANSIColor::color('blue'), + about => Term::ANSIColor::color('magenta'), + amnesty => Term::ANSIColor::color('cyan'), + assert => Term::ANSIColor::color('bold bright_white'), + control => Term::ANSIColor::color('bold red'), + error => Term::ANSIColor::color('yellow'), + info => Term::ANSIColor::color('yellow'), + meta => Term::ANSIColor::color('magenta'), + parent => Term::ANSIColor::color('magenta'), + trace => Term::ANSIColor::color('bold red'), + ); +} + +# These colors all look decent enough to use, ordered to avoid putting similar ones together +use constant DEFAULT_JOB_COLOR_NAMES => ( + 'bold green on_blue', + 'bold blue on_white', + 'bold black on_cyan', + 'bold green on_bright_black', + 'bold dark blue on_white', + 'bold black on_green', + 'bold cyan on_blue', + 'bold black on_white', + 'bold white on_cyan', + 'bold cyan on_bright_black', + 'bold white on_green', + 'bold bright_black on_white', + 'bold white on_blue', + 'bold bright_cyan on_green', + 'bold blue on_cyan', + 'bold white on_bright_black', + 'bold bright_black on_green', + 'bold bright_green on_blue', + 'bold bright_blue on_white', + 'bold bright_white on_bright_black', + 'bold yellow on_blue', + 'bold bright_black on_cyan', + 'bold bright_green on_bright_black', + 'bold blue on_green', + 'bold bright_cyan on_blue', + 'bold bright_blue on_cyan', + 'bold dark bright_white on_bright_black', + 'bold bright_blue on_green', + 'bold dark bright_blue on_white', + 'bold bright_white on_blue', + 'bold bright_cyan on_bright_black', + 'bold bright_white on_cyan', + 'bold bright_white on_green', + 'bold bright_yellow on_blue', + #'bold magenta on_white', + #'bold dark magenta on_white', + #'bold dark cyan on_white', + 'bold dark bright_cyan on_bright_black', + #'bold dark bright_green on_black', + #'bold dark bright_yellow on_black', +); + +sub DEFAULT_JOB_COLOR() { + return map { Term::ANSIColor::color($_) } DEFAULT_JOB_COLOR_NAMES; +} + +sub DEFAULT_COLOR() { + return ( + reset => Term::ANSIColor::color('reset'), + blob => Term::ANSIColor::color('bold bright_black on_white'), + tree => Term::ANSIColor::color('bold bright_white'), + tag_border => Term::ANSIColor::color('bold bright_white'), + ); +} + +my %FACET_TAG_BORDERS = ( + 'default' => ['[', ']'], + 'amnesty' => ['{', '}'], + 'info' => ['(', ')'], + 'error' => ['<', '>'], + 'parent' => [' ', ' '], +); + +sub init { + my $self = shift; + + $self->{+COMPOSER} ||= Test2::Formatter::Test2::Composer->new; + + $self->{+VERBOSE} = 1 unless defined $self->{+VERBOSE}; + + $self->{+JOB_LENGTH} ||= 2; + + my $io = $self->{+IO} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + + $self->{+TTY} = -t $io unless defined $self->{+TTY}; + + my $use_color = ref($self->{+COLOR}) ? 1 : delete($self->{+COLOR}); + $use_color = $self->{+TTY} unless defined $use_color; + + if ($use_color && USE_ANSI_COLOR) { + $self->{+SHOW_BUFFER} = 1 unless defined $self->{+SHOW_BUFFER}; + + if ($use_color) { + $self->{+COLOR} = { + DEFAULT_COLOR(), + TAGS => {DEFAULT_TAG_COLOR()}, + FACETS => {DEFAULT_FACET_COLOR()}, + JOBS => [DEFAULT_JOB_COLOR()], + } unless defined $self->{+COLOR}; + + $self->{+JOB_COLORS} = {free => [@{$self->{+COLOR}->{JOBS}}]}; + } + } + else { + $self->{+SHOW_BUFFER} = 0 unless defined $self->{+SHOW_BUFFER}; + } + + $self->{+ECOUNT} //= 0; + + my $reset = $use_color ? Term::ANSIColor::color('reset') : ''; + my $cyan = $use_color ? Term::ANSIColor::color('cyan') : ''; + $self->{+_ACTIVE_DISP} = ["[${cyan}INITIALIZING${reset}]", '']; + $self->{+_FILE_STATS} = { + passed => 0, + failed => 0, + running => 0, + todo => 0, + total => 0, + }; + + +} + +sub io { + my $self = shift; + my ($job_id) = @_; + return $self->{+IO} unless defined $job_id; + return $self->{+JOB_IO}->{$job_id} // $self->{+IO}; +} + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc, $job_id) = @_; + if (defined $job_id) { + my $io; + + unless ($io = $self->{+ENC_IO}->{$enc}) { + $io = $self->{+ENC_IO}->{$enc} = clone_io($self->{+IO} || \*STDOUT) or die "Cannot get a filehandle: $!"; + $io->autoflush(1); + apply_encoding($io, $enc); + } + + $self->{+JOB_IO}->{$job_id} = $io; + } + else { + apply_encoding($self->{+IO}, $enc); + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + $f ||= $e->facet_data; + + my $should_show = $self->update_active_disp($f); + + $self->{+ECOUNT}++; + + my $job_id = $f->{harness}->{job_id}; + $self->encoding($f->{control}->{encoding}, $job_id) if $f->{control}->{encoding}; + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + return if $depth && (!$self->{+SHOW_BUFFER} || !$self->{+PROGRESS}); + + my $lines; + if (!$self->{+VERBOSE}) { + if ($depth) { + $lines = []; + } + else { + $lines = $self->render_quiet($f); + } + } + elsif ($depth) { + my $tree = $self->render_tree($f, '>'); + $lines = $self->render_buffered_event($f, $tree); + } + else { + my $tree = $self->render_tree($f,); + $lines = $self->render_event($f, $tree); + } + + $should_show ||= $lines && @$lines; + unless ($should_show || $self->{+VERBOSE}) { + if (my $last = $self->{last_rendered}) { + return if time - $last < 0.2; + $self->{last_rendered} = time; + } + else { + $self->{last_rendered} = time; + } + } + + push @{$self->{+JOB_COLORS}->{free}} => delete $self->{+JOB_COLORS}->{used}->{$job_id} + if $job_id && $f->{harness_job_end}; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + my $io = $self->io($job_id); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if (!$self->{+VERBOSE}) { + print $io $_, "\n" for @$lines; + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status($f); + $self->{+_BUFFERED} = 1; + } + } + elsif ($depth && $lines && @$lines && !$self->{+INTERACTIVE}) { + print $io $lines->[0]; + $self->{+_BUFFERED} = 1; + } + else { + print $io $_, "\n" for @$lines; + } + + delete $self->{+JOB_IO}->{$job_id} if $job_id && $f->{harness_job_end}; +} + +sub finalize { + my $self = shift; + + my $io = $self->{+IO}; + print $io "\r\e[K" if $self->{+_BUFFERED}; + + return; +} + +sub step { + my $self = shift; + + return unless $self->update_active_disp; + + my $io = $self->io(0); + if ($self->{+_BUFFERED}) { + print $io "\r\e[K"; + $self->{+_BUFFERED} = 0; + } + + if ($self->{+TTY} && $self->{+PROGRESS}) { + print $io $self->render_status(); + $self->{+_BUFFERED} = 1; + } +} + +sub update_active_disp { + my $self = shift; + my ($f) = @_; + my $should_show = 0; + + my $stats = $self->{+_FILE_STATS}; + + my $out = 0; + $out = $self->update_spinner($stats) unless $stats->{started}; + + return $out unless $f; + + if (my $task = $f->{harness_job_queued}) { + $self->{+JOB_NAMES}->{$task->{job_id}} = $task->{job_name} || $task->{job_id}; + $stats->{total}++; + $stats->{todo}++; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($job->{file})} = $job->{job_name} || $job->{job_id}; + $should_show = 1; + $stats->{running}++; + $stats->{todo}--; + $stats->{started} //= 1; + } + + if ($f->{harness_job_end}) { + my $file = $f->{harness_job_end}->{file}; + delete $self->{+ACTIVE_FILES}->{File::Spec->abs2rel($file)}; + $should_show = 1; + $stats->{running}--; + + if ($f->{harness_job_end}->{fail}) { + $stats->{failed}++; + } + else { + $stats->{passed}++; + } + } + + return $out unless $should_show; + + my $statline = join '|' => ( + $self->_highlight($stats->{passed}, 'P', 'green'), + $self->_highlight($stats->{failed}, 'F', 'red'), + $self->_highlight($stats->{running}, 'R', 'cyan'), + $self->_highlight($stats->{todo}, 'T', 'yellow'), + ); + + $statline = "[$statline]"; + + my $active = $self->{+ACTIVE_FILES}; + + return $self->{+_ACTIVE_DISP} = [$statline, ''] unless $active && keys %$active; + + my $reset = $self->reset; + + my $str .= "("; + { + no warnings 'numeric'; + $str .= join(' ' => map { m{([^/]+)$}; "$active->{$_}:$1" } sort { ($active->{$a} || 0) <=> ($active->{$b} || 0) or $a cmp $b } keys %$active); + } + $str .= ")"; + + $self->{+_ACTIVE_DISP} = [$statline, $str]; + + return 1; +} + +sub update_spinner { + my $self = shift; + my ($stats) = @_; + + $stats->{spinner} //= '|'; + $stats->{spinner_time} //= time - 1; + $stats->{blink_time} //= time - 1; + $stats->{blink} //= ''; + + if (time - $stats->{spinner_time} > 0.1) { + $stats->{spinner_time} = time; + my $start = substr($stats->{spinner}, 0, 1); + $stats->{spinner} = '\\' if $start eq '-'; + $stats->{spinner} = '-' if $start eq '/'; + $stats->{spinner} = '/' if $start eq '|'; + $stats->{spinner} = '|' if $start eq '\\'; + } + elsif(time - $stats->{blink_time} > 0.5) { + $stats->{blink_time} = time; + $stats->{blink} = $stats->{blink} ? '' : 'bold bright_'; + } + else { + return 0; + } + + my $yellow = $self->{+COLOR} ? Term::ANSIColor::color($stats->{blink} . 'yellow') : ''; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + my $green = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_green') : ''; + my $bold = $self->{+COLOR} ? Term::ANSIColor::color('bold bright_white') : ''; + my $reset = $self->reset; + + $self->{+_ACTIVE_DISP} = [ + join( + '' => ( + $bold => "[ ", $reset, + $green => $stats->{spinner}, $reset, + '' => " ", + $self->{+IS_PERSISTENT} + ? ( + $yellow => "Waiting for busy runner", $reset, + '' => " ", + $reset => "(see ", $reset, + $cyan => "yath status", $reset, + $reset => ")", $reset, + ) + : ($yellow => "INITIALIZING", $reset), + '' => " ", + $green => $stats->{spinner}, $reset, + $bold => " ]", $reset, + ) + ), + '', + ]; + + return 1; +} + +sub _highlight { + my $self = shift; + my ($val, $label, $color) = @_; + + return "${label}:${val}" unless $val && $self->{+COLOR}; + return sprintf('%s%s:%d%s', Term::ANSIColor::color($color), $label, $val, $self->reset); +} + + +sub colorstrip { + my $self = shift; + my ($str) = @_; + + return $str unless USE_ANSI_COLOR; + return Term::ANSIColor::colorstrip($str); +} + +sub render_status { + my $self = shift; + + my $reset = $self->reset; + my $cyan = $self->{+COLOR} ? Term::ANSIColor::color('cyan') : ''; + + my $str = "$self->{+_ACTIVE_DISP}->[0] Events: $self->{+ECOUNT} ${cyan}$self->{+_ACTIVE_DISP}->[1]${reset}"; + + my $max = term_size() || 80; + + if (length($str) > $max) { + my $nocolor = $self->colorstrip($str); + $str = substr($nocolor, 0, $max - 8) . " ...)$reset" if length($nocolor) > $max; + $str =~ s/\(/$cyan(/; + $str =~ s/^\[[^\]]+\]/$self->{+_ACTIVE_DISP}->[0]/; + } + + return $str; +} + +sub render_buffered_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comp = $self->{+COMPOSER}->render_one_line($f) or return; + + return unless @$comp; + return [$self->build_line($tree, @$comp)]; +} + +sub render_event { + my $self = shift; + my ($f, $tree) = @_; + + my $comps = $self->{+COMPOSER}->render_verbose($f); + + my (@parent, @times); + + if ($f->{parent}) { + @parent = $self->render_parent($f, $tree); + + if (@$comps && $comps->[-1]->[0] eq 'times') { + my $times = pop(@$comps); + @times = $self->build_line($tree, @$times); + } + } + + my @out; + + for my $comp (@$comps) { + my $ctree = $tree; + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + push @out => (@parent, @times); + + return \@out; +} + +sub render_quiet { + my $self = shift; + my ($f, $tree) = @_; + + my @out; + + my $comps = $self->{+COMPOSER}->render_brief($f); + for my $comp (@$comps) { + my $ctree = $tree ||= $self->render_tree($f); + substr($ctree, -2, 2, '+~') if $comp->[0] eq 'assert' && $f->{parent}; + push @out => $self->build_line($ctree, @$comp); + } + + if ($f->{parent} && !$f->{amnesty}) { + push @out => $self->render_parent($f, $tree ||= $self->render_tree($f), quiet => 1); + } + + return \@out; +} + +sub reset { + my $self = shift; + return $self->{+COLOR} ? $self->{+COLOR}->{reset} : ''; +} + +sub job_color { + my $self = shift; + my ($id, $set) = @_; + return '' unless $self->{+JOB_COLORS}; + return $self->{+JOB_COLORS}->{used}->{$id} || '' unless $set; + return $self->{+JOB_COLORS}->{used}->{$id} ||= shift @{$self->{+JOB_COLORS}->{free}} || ''; +} + +sub render_tree { + my $self = shift; + my ($f, $char) = @_; + $char ||= '|'; + + my $job = ''; + if ($f->{harness} && $f->{harness}->{job_id}) { + my $id = $f->{harness}->{job_id}; + my $name = $self->{+JOB_NAMES}->{$id}; + + my ($color, $reset) = ('', ''); + if ($self->{+JOB_COLORS}) { + $color = $self->job_color($id, 'set'); + $reset = $self->reset; + } + + my $len = length($name); + if (!$self->{+JOB_LENGTH} || $len > $self->{+JOB_LENGTH}) { + $self->{+JOB_LENGTH} = $len; + } + else { + $len = $self->{+JOB_LENGTH}; + } + + $job = sprintf("%sjob %${len}s%s ", $color, $name, $reset || ''); + } + + my $hf = hub_truth($f); + my $depth = $hf->{nested} || 0; + + my @pipes = (' ', map $char, 1 .. $depth); + return join(' ' => $job, @pipes) . ' '; +} + +sub build_line { + my $self = shift; + my ($tree, $facet, $tag, $text) = @_; + + $tree ||= ''; + $tag ||= ''; + $text ||= ''; + chomp($text); + + substr($tree, -2, 1, '+') if $facet eq 'assert'; + + $tag = substr($tag, 0 - TAG_WIDTH, TAG_WIDTH) if length($tag) > TAG_WIDTH; + + my $max = $self->{+TTY} && !$self->{+NO_WRAP} ? (term_size() || 80) : undef; + my $color = $self->{+COLOR}; + my $reset = $self->reset; + my $tcolor = $color ? $color->{TAGS}->{$tag} || $color->{FACETS}->{$facet} || '' : ''; + + my ($ps, $pe) = @{$FACET_TAG_BORDERS{$facet} || $FACET_TAG_BORDERS{default}}; + + $tag = uc($tag); + my $length = length($tag); + if ($length > TAG_WIDTH) { + $tag = substr($tag, 0, TAG_WIDTH); + } + elsif($length < TAG_WIDTH) { + my $pad = (TAG_WIDTH - $length) / 2; + my $padl = $pad + (TAG_WIDTH - $length) % 2; + $tag = (' ' x $padl) . $tag . (' ' x $pad); + } + + my $start; + if ($color) { + my $border = $color->{tag_border} || ''; + $start = "${reset}${border}${ps}${reset}${tcolor}${tag}${reset}${border}${pe}${reset}"; + } + else { + $start = "${ps}${tag}${pe}"; + } + $start .= " "; + + if ($tree) { + if ($color) { + my $trcolor = $color->{tree} || ''; + $start .= $trcolor . $tree . $reset; + } + else { + $start .= $tree; + } + } + + my @lines = split /[\r\n]/, $text; + @lines = ($text) unless @lines; + + my @out; + for my $line (@lines) { + if(@lines > 1 && $max && length("$ps$tag$pe $tree$line") > $max) { + @out = (); + last; + } + + if ($color) { + push @out => "${start}${tcolor}${line}$reset"; + } + else { + push @out => "${start}${line}"; + } + } + + return @out if @out; + + return ( + "$start----- START -----", + $text, + "$start------ END ------", + ) unless $color; + + my $blob = $color->{blob} || ''; + return ( + "$start${blob}----- START -----$reset", + "${tcolor}${text}${reset}", + "$start${blob}------ END ------$reset", + ); +} + +sub render_parent { + my $self = shift; + my ($f, $tree, %params) = @_; + + my $meth = $params{quiet} ? 'render_quiet' : 'render_event'; + + my @out; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness} ||= $f->{harness}; + my $tree = $self->render_tree($sf); + push @out => @{$self->$meth($sf, $tree)}; + } + + return unless @out; + + push @out => ( + $self->build_line("$tree^", 'parent', '', ''), + ); + + return @out; +} + + +sub DESTROY { + my $self = shift; + + my $io = $self->{+IO} or return; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + + print $io Term::ANSIColor::color('reset') + if USE_ANSI_COLOR; + + print $io "\n"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2 - An alternative to TAP, used by Test2::Harness. + +=head1 DESCRIPTION + +This formatter is the primary formatter used for final result rendering when +you use Test2::Harness. This formatter is NOT designed to have its output +consumed by code/machine/harnesses. The goal of this formatter is to have +output that is easily read by humans. + +=head1 SYNOPSIS + +If you are running a test directly with perl and want to use this formatter: + + $ perl -MTest2::Formatter::Test2 path/to/test.t + +You could also use the module directly in your test, but that is not +recommended as your test would then be unable to be run via prove or other +harnesses. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Formatter/Test2/Composer.pm b/liby/Test2/Formatter/Test2/Composer.pm new file mode 100644 index 000000000..d6b642d19 --- /dev/null +++ b/liby/Test2/Formatter/Test2/Composer.pm @@ -0,0 +1,507 @@ +package Test2::Formatter::Test2::Composer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use List::Util qw/first/; + +sub new { + my $class = shift; + return bless({}, $class); +} + +sub render_one_line { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + return [$f->{render}->[0]->{facet}, uc($f->{render}->[0]->{tag}), $f->{render}->[0]->{details}] + if $f->{render} && @{$f->{render}}; + + return (($class->halt($f))[0]) if $class->{control} && defined $class->{control}->{halt}; + + for my $type (qw/assert errors plan info times about/) { + next unless $f->{$type}; + my $m = "render_$type"; + my ($out) = $class->$m($f); + return $out if defined $out; + } + + return; +} + +sub render_verbose { + my $class = shift; + my ($in, %params) = @_; + + my $f = blessed($in) ? $in->facet_data : $in; + + return [map {[$_->{facet}, uc($_->{tag}), $_->{details}]} @{$f->{render}}] + if $f->{render} && @{$f->{render}}; + + my @out; + + push @out => $class->render_control($f, %params) if $f->{control}; + push @out => $class->render_plan($f) if $f->{plan}; + + if ($f->{assert}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{pass} || $f->{assert}->{no_debug}; + push @out => $class->render_amnesty($f) if $f->{amnesty} && @{$f->{amnesty}}; + } + + push @out => $class->render_info($f) if $f->{info}; + push @out => $class->render_errors($f) if $f->{errors}; + + push @out => $class->render_about($f) + if $f->{about} && !(@out || first { $f->{$_} } qw/stop plan info nest assert/); + + return \@out; +} + +sub render_super_verbose { + my $class = shift; + my ($in) = @_; + + my $out = $class->render_verbose($in, super_verbose => 1); + + my $f = blessed($in) ? $in->facet_data : $in; + + push @$out => $class->render_launch($f) if $f->{harness_job_launch}; + push @$out => $class->render_start($f) if $f->{harness_job_start}; + push @$out => $class->render_exit($f) if $f->{harness_job_exit}; + push @$out => $class->render_end($f) if $f->{harness_job_end}; + + unless (@$out) { + my ($name, $fallback); + for my $k (sort keys %$f) { + my $v = $f->{$k}; + + # Fallback should be longest harness* facet name + $fallback = $k if $k =~ m/harness/ && (!$fallback || length($fallback) < length($k)); + + my $list = ref($v) eq 'ARRAY' ? $v : [$v]; + for my $i (@$list) { + next unless ref($i); + last if $name = $i->{details}; + } + } + + $name //= $fallback // join ', ' => sort keys %$f; + + push @$out => ['harness', 'HARNESS', $name]; + } + + return $out; +} + +sub render_launch { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', 'Job Launched at ' . $f->{harness_job_launch}->{stamp}]; +} + +sub render_start { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_start}->{details}]; +} + +sub render_exit { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', $f->{harness_job_exit}->{details}]; +} + +sub render_end { + my $class = shift; + my ($f) = @_; + + return ['harness', 'HARNESS', "Job completed at " . $f->{harness_job_end}->{stamp}]; +} + +sub render_control { + my $class = shift; + my ($f, %params) = @_; + + my @out; + + push @out => ['control', 'HALT', $f->{control}->{details}] + if defined $f->{control}->{halt}; + + return @out unless $params{super_verbose}; + + push @out => ['control', 'ENCODING', $f->{control}->{encoding}] + if $f->{control}->{encoding}; + + return @out if @out; + + return ['control', 'CONTROL', $f->{control}->{details}] + if defined $f->{control}->{details}; + + return; +} + +my %SHOW_BRIEF_TAGS = ( + 'CRITICAL' => 1, + 'DEBUG' => 1, + 'DIAG' => 1, + 'ERROR' => 1, + 'FAIL' => 1, + 'FAILED' => 1, + 'FATAL' => 1, + 'HALT' => 1, + 'PASSED' => 1, + 'REASON' => 1, + 'STDERR' => 1, + 'TIMEOUT' => 1, + 'WARN' => 1, + 'WARNING' => 1, + 'KILL' => 1, + 'SKIPPED' => 1, +); + +my %SHOW_BRIEF_FACETS = ( + control => 1, + error => 1, + trace => 1, +); + +sub render_brief { + my $class = shift; + my $in = shift; + my $f = blessed($in) ? $in->facet_data : $in; + + if ($f->{render} && @{$f->{render}}) { + my @show = grep { $SHOW_BRIEF_TAGS{uc($_->{tag})} || $SHOW_BRIEF_FACETS{lc($_->{facet})} } @{$f->{render}}; + return [map { [$_->{facet}, uc($_->{tag}), $_->{details}] } @show]; + } + + my @out; + + push @out => $class->render_control($f) if $f->{control}; + + if ($f->{assert} && !$f->{assert}->{pass} && !$f->{amnesty}) { + push @out => $class->render_assert($f); + push @out => $class->render_debug($f) unless $f->{assert}->{no_debug}; + } + + if ($f->{info}) { + my $if = {%$f, info => [grep { $_->{debug} || $_->{important} } @{$f->{info}}]}; + push @out => $class->render_info($if) if @{$if->{info}}; + } + + push @out => $class->render_errors($f) if $f->{errors}; + + return \@out; +} + +sub render_plan { + my $class = shift; + my ($f) = @_; + + my $plan = $f->{plan}; + return ['plan', 'NO PLAN', $f->{plan}->{details}] if $plan->{none}; + + if ($plan->{skip}) { + return ['plan', 'SKIP ALL', $f->{plan}->{details}] + if $f->{plan}->{details}; + + return ['plan', 'SKIP ALL', "No reason given"]; + } + + return ['plan', 'PLAN', "Expected assertions: $f->{plan}->{count}"]; +} + +sub render_assert { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details} || '<UNNAMED ASSERTION>'; + + return ['assert', '! PASS !', $name] + if $f->{amnesty} && @{$f->{amnesty}}; + + return ['assert', 'PASS', $name] + if $f->{assert}->{pass}; + + return ['assert', 'FAIL', $name] +} + +sub render_amnesty { + my $class = shift; + my ($f) = @_; + + my %seen; + return map { + $seen{join '' => @{$_}{qw/tag details/}}++ + ? () + : ['amnesty', $_->{tag}, $_->{details}] + } @{$f->{amnesty}}; +} + +sub render_debug { + my $class = shift; + my ($f) = @_; + + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug; + if ($trace) { + $debug = $trace->{details}; + if(!$debug && $trace->{frame}) { + my $frame = $trace->{frame}; + $debug = "$frame->[1] line $frame->[2]"; + } + } + + $debug ||= "[No trace info available]"; + + chomp($debug); + + return ['trace', 'DEBUG', $debug]; +} + +sub render_info { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details} // ''; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + ['info', $_->{tag}, $details, $_->{table} || ()] + } @{$f->{info}}; +} + +sub render_about { + my $class = shift; + my ($f) = @_; + + return if $f->{about}->{no_display}; + return unless $f->{about} && $f->{about}->{details}; + + my $type; + if ($f->{about}->{package}) { + my $type = $f->{about}->{package}; + $type =~ s/^.*:://; + } + $type //= 'ABOUT'; + + return ['about', $type, $f->{about}->{details}]; +} + +sub render_errors { + my $class = shift; + my ($f) = @_; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + } + + my $tag = $_->{tag} || ($_->{fail} ? 'FATAL' : 'ERROR'); + + ['error', $tag, $details] + } @{$f->{errors}}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::Test2::Composer - Compose output components from event facets + +=head1 DESCRIPTION + +This is used by L<Test2::Formatter::Test2> to turn events into output +components. This logic lives here instead of in the formatter because it is +also used by L<Test2::Harness::UI>. Other tools may also find this conversion +useful. + +=head1 SYNOPSIS + + use Test2::Formatter::Test2::Composer; + + # Note, all methods are class methods, this is just here for convenience. + my $comp = Test2::Formatter::Test2::Composer->new(); + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + ... + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=head1 METHODS + +All methods are class methods, but they also work just fine on a blessed +instance. There is no benefit to a blessed instance, but you can create one for +convenience if it makes you more comfortable. + +=over 4 + +=item $inst = $class->new() + +Create a blessed instance. This is here for convenience only. All methods are +class methods. + +=item $arrayref = $class->render_one_line($event) + +=item $arrayref = $class->render_one_line(\%facet_data) + + my $out = $comp->render_one_line($event); + my ($facet_name, $tag_string, $text_for_humans) = @$out; + +This will return a single line of output from the event, even if the event +would normally return multiple lines. + +In order of priority: + +=over 4 + +=item Custom 'render' facet + +=item Control 'halt' facet (bail-out) + +=item Assertion (pass/fail) + +=item Error message + +=item Plan + +=item Info (note/diag) + +=item Timing data + +=item About + +=back + +=item @lines = $class->render_verbose($event, %control_params) + +=item @lines = $class->render_verbose(\%facet_data, %control_params) + +This will verbosely render any event. The C<%control_params> are passed +directly to C<render_control()> and are not used for anything else. + + for my $line ($comp->render_verbose($event)) { + my ($facet_name, $tag_string, $text_for_humans) = @$line; + ..., + } + +=item @lines = $class->render_super_verbose($event) + +=item @lines = $class->render_super_verbose(\%facet_data) + +This is even more verbose than C<render_verbose()> because it produces output +lines even for facets that should normally not be seen, things that would +usually be considered noise. + +This is mainly useful for tools that allow deep inspection of log files. + +=back + +=head2 FACET RENDERERS + +With exception of C<render_control()> these are all the same. These all take +C<\%facet_data> as their only argument, and return a list of line-arrayrefs +C<[$facet, $tag, $text_for_humans]>. + +=over 4 + +=item @lines = $class->render_control(\%facet_data, super_verbose => $bool) + +This specific one is special in that it can take an extra argument. This +argument is used to toggle between super_verbose and regular verbosity. No +other facet renderer needs this toggle. If omitted it defaults to not being +super verbose. + +=item @lines = $class->render_launch(\%facet_data) + +=item @lines = $class->render_start(\%facet_data) + +=item @lines = $class->render_exit(\%facet_data) + +=item @lines = $class->render_end(\%facet_data) + +=item @lines = $class->render_brief(\%facet_data) + +=item @lines = $class->render_plan(\%facet_data) + +=item @lines = $class->render_assert(\%facet_data) + +=item @lines = $class->render_amnesty(\%facet_data) + +=item @lines = $class->render_debug(\%facet_data) + +=item @lines = $class->render_info(\%facet_data) + +=item @lines = $class->render_about(\%facet_data) + +=item @lines = $class->render_errors(\%facet_data) + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness.pm b/liby/Test2/Harness.pm new file mode 100644 index 000000000..de5d06345 --- /dev/null +++ b/liby/Test2/Harness.pm @@ -0,0 +1,60 @@ +package Test2::Harness; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness - A new and improved test harness with better L<Test2> +integration. + +=head1 DESCRIPTION + +Test2::Harness is the backend code that handles running/processing the tests. +In general a user will not use it directly, instead you should probably be +looking at L<App::Yath> which is the UI layer built around Test2::Harness. + +=head1 SEE ALSO + +The primary documentation can be found in L<App::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Aggregator.pm b/liby/Test2/Harness/Aggregator.pm new file mode 100644 index 000000000..4caf371e3 --- /dev/null +++ b/liby/Test2/Harness/Aggregator.pm @@ -0,0 +1,140 @@ +package Test2::Harness::Aggregator; +use strict; +use warnings; + +use Carp qw/croak/; +use POSIX qw/mkfifo/; + +use Test2::Harness::Util::JSON qw/encode_json/; + +use Atomic::Pipe; +use Test2::Harness::Util::File::Stream; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + -fifo_file + -output_file + -state + -name +}; + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + croak "'fifo_file' is a required attribute" unless $self->{+FIFO_FILE}; + croak "'output_file' is a required attribute" unless $self->{+OUTPUT_FILE}; + croak "'state' is a required attribute" unless $self->{+STATE}; +} + +sub run { + my $self = shift; + my ($parent_pid) = @_; + + my $outfh = Test2::Harness::Util::File::Stream->new(name => $self->{+OUTPUT_FILE}); + $outfh->write(); # Touch the file + + my $sig = 0; + + my $ok = eval { + $SIG{__WARN__} = sub { + print STDERR @_; + $outfh->write(encode_json({ + facet_data => { + info => [ + {tag => 'AGG WARN', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + }; + + my $fifo; + + local $SIG{INT} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGINT\n"; + $sig = 'INT'; + $fifo->blocking(0) if $fifo; + }; + + local $SIG{TERM} = sub { + print STDERR "Aggregator ($self->{+NAME}) Got SIGTERM\n"; + $sig = 'TERM'; + $fifo->blocking(0) if $fifo; + }; + + mkfifo($self->{+FIFO_FILE}, 0700) or die "Failed to create fifo ($self->{+FIFO_FILE}): $!"; + + $fifo = Atomic::Pipe->read_fifo($self->{+FIFO_FILE}); + $fifo->resize($fifo->max_size); + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + $data->aggregators->{$self->{+NAME}} = { + pid => $$, + name => $self->{+NAME}, + fifo => $self->{+FIFO_FILE}, + output => $self->{+OUTPUT_FILE}, + }; + + $data->processes->{$$} = {type => 'aggregator', parent => $parent_pid, pid => $$, name => $self->{+NAME}}; + } + ); + + while (1) { + $fifo->blocking(0) if $sig; + + my $event = $fifo->read_message; + + if ($sig && !$event) { + $outfh->write(encode_json({ + facet_data => { + info => [ + {tag => "AGG SIG", details => "(AGGREGATOR) got SIG${sig}"}, + ], + } + }) . "\n"); + $outfh->write("null\n"); + last; + } + + chomp($event); + + next if $event eq 'null'; + + if ($event eq 'TERMINATE') { + $outfh->write("null\n"); + last; + } + + $outfh->write("$event\n"); + } + + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + delete $data->{aggregators}->{$self->{+NAME}}; + delete $data->processes->{$$}; + }, + ); + + 1; + }; + my $err = $@; + + kill($sig, $$) if $sig; + + return 0 if $ok; + + print STDERR $err; + $outfh->write(encode_json({ + facet_data => { + info => [ + {tag => 'AGG DIED', details => "(AGGREGATOR) " . join ' ' => @_}, + ], + } + }) . "\n"); + + return 255; +} diff --git a/liby/Test2/Harness/Auditor.pm b/liby/Test2/Harness/Auditor.pm new file mode 100644 index 000000000..c594246e5 --- /dev/null +++ b/liby/Test2/Harness/Auditor.pm @@ -0,0 +1,176 @@ +package Test2::Harness::Auditor; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; +use Time::HiRes qw/time/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use Test2::Harness::Event; +use Test2::Harness::Auditor::Watcher; + +use Test2::Harness::Util::HashBase qw{ + <action + <run_id + + +broken + + <watchers + <queued +}; + +sub init { + my $self = shift; + + $self->{+WATCHERS} //= {}; +} + +sub process { + my $self = shift; + + while (my $line = <STDIN>) { + my $data = decode_json($line); + last unless defined $data; + my $e = Test2::Harness::Event->new($data); + + # If process_event does not return anything we need to record just this + # event. If it does return then we want to record what it returns. + if (my @events = $self->process_event($e)) { + $self->{+ACTION}->($_) for @events; + } + else { + $self->{+ACTION}->($e); + } + } +} + +sub process_event { + my $self = shift; + my ($e) = @_; + + my $job_id = $e->job_id; + my $job_try = $e->job_try // 0; + + # Do nothing for non-job events + return $e unless $job_id; + + my $f = $e->facet_data; + + if (my $task = $f->{harness_job_queued}) { + $self->{+WATCHERS}->{$job_id} //= []; + $self->{+QUEUED}->{$job_id} //= $task; + return $e; + } + + my $tries = $self->{+WATCHERS}->{$job_id} or return $self->broken($e, "Never saw queue entry"); + + if (my $job = $f->{harness_job}) { + $tries->[$job_try] = Test2::Harness::Auditor::Watcher->new(job => $job, try => $job_try); + } + + my $watcher = $tries->[$job_try] or return $self->broken($e, "never saw harness_job facet"); + + return $watcher->process($e); +} + +sub broken { + my $self = shift; + my ($e, $message) = @_; + + $self->{+BROKEN}->{$e->job_id}++; + + push @{$e->facet_data->{errors} //= []} => {details => $message, fail => 1}; + + return $e; +} + +sub finish { + my $self = shift; + + my $final_data = {pass => 1}; + + while (my ($job_id, $watchers) = each %{$self->{+WATCHERS}}) { + my $file = File::Spec->abs2rel($self->{+QUEUED}->{$job_id}->{file}); + + if (@$watchers) { + push @{$final_data->{failed}} => [$job_id, $file, $watchers->[-1]->failed_subtest_tree] if $watchers->[-1]->fail; + push @{$final_data->{retried}} => [$job_id, scalar(@$watchers), $file, $watchers->[-1]->pass ? 'YES' : 'NO'] if @$watchers > 1; + + if (my $halt = $watchers->[-1]->halt) { + push @{$final_data->{halted}} => [$job_id, $file, $halt]; + } + } + else { + push @{$final_data->{unseen}} => [$job_id, $self->{+QUEUED}->{$job_id}->{file}]; + } + } + + $final_data->{pass} = 0 if $final_data->{failed} or $final_data->{unseen}; + + my $e = Test2::Harness::Event->new( + job_id => 0, + stamp => time, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => {harness_final => $final_data}, + ); + + $self->{+ACTION}->($e); + $self->{+ACTION}->(undef); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor - Auditor that validates test results by processing an +event stream. + +=head1 DESCRIPTION + +The auditor is responsible for taking a stream of events and determining what +is passing or failing. An L<Test2::Harness::Auditor::Watcher> instance is +created for every job_id seen, and events for each job are passed to the proper +watcher for state management. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Auditor/TimeTracker.pm b/liby/Test2/Harness/Auditor/TimeTracker.pm new file mode 100644 index 000000000..7da18c0fa --- /dev/null +++ b/liby/Test2/Harness/Auditor/TimeTracker.pm @@ -0,0 +1,370 @@ +package Test2::Harness::Auditor::TimeTracker; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/hub_truth/; +use Test2::Util::Times qw/render_duration/; + +use Test2::Harness::Util::HashBase qw{ + -start -start_id + -stop -stop_id + -first -first_id + -last -last_id + -complete_id + + -_source + -_totals +}; + +sub process { + my $self = shift; + my ($event, $f, $assertion_count) = @_; + + # Invalidate cache + delete $self->{+_TOTALS}; + delete $self->{+_SOURCE}; + + my $stamp = $event->{stamp} or return; + my $id = $event->{event_id} // 'N/A'; + + $f //= $event->{facet_data}; + + if ($f->{harness_job_exit}) { + $self->{+STOP} = $stamp; + $self->{+STOP_ID} = $id; + } + + return if $self->{+COMPLETE_ID}; + + if ($f->{harness_job_start}) { + $self->{+START} = $stamp; + $self->{+START_ID} = $id; + } + + # These events absolutely end the events phase, and do not count as part of + # it. + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{harness_job_exit}; + $self->{+COMPLETE_ID} //= $event->{event_id} if $f->{control} && $f->{control}->{phase} && $f->{control}->{phase} eq 'END'; + + return if $self->{+COMPLETE_ID}; + + # Plan still counts as 'event' phase, so do not return if we are setting this now + $self->{+COMPLETE_ID} //= $event->{event_id} if $assertion_count && $f->{plan} && !$f->{plan}->{none}; + + return unless $f->{trace}; # Events with traces are "event" phase. + + # Always replace the last, if we got this far. + $self->{+LAST} = $stamp; + $self->{+LAST_ID} = $id; + + # Only set the first one once + return if $self->{+FIRST}; + $self->{+FIRST} = $stamp; + $self->{+FIRST_ID} = $id; + + return; +} + +sub useful { + my $self = shift; + + my @got = grep { defined $self->{$_} } START, FIRST, LAST, STOP; + return @got > 1; +} + +my @TOTAL_FIELDS = qw/startup events cleanup total/; +my %TOTAL_SOURCES = ( + startup => [FIRST, START], + events => [LAST, FIRST], + cleanup => [STOP, LAST], + total => [STOP, START] +); +my %TOTAL_DESC = ( + startup => "Time from launch to first test event.", + events => "Time spent generating test events.", + cleanup => "Time from last test event to test exit.", + total => "Total time", +); + +sub totals { + my $self = shift; + + return $self->{+_TOTALS} if $self->{+_TOTALS}; + + my $out = {}; + + for my $field (@TOTAL_FIELDS) { + my $sources = $TOTAL_SOURCES{$field} or die "Invalid field: $field"; + my @vals = @{$self}{@$sources}; + next unless defined($vals[0]) && defined($vals[1]); + + my $delta = $vals[0] - $vals[1]; + $out->{$field} = $delta; + $out->{"h_$field"} = render_duration($delta); + } + + return $self->{+_TOTALS} = $out; +} + +sub source { + my $self = shift; + + return $self->{+_SOURCE} if $self->{+_SOURCE}; + + my @fields = ( + START, START_ID, + STOP, STOP_ID, + FIRST, FIRST_ID, + LAST, LAST_ID, + COMPLETE_ID, + ); + + my %out; + @out{@fields} = @{$self}{@fields}; + + return $self->{+_SOURCE} = \%out; +} + +sub data_dump { + my $self = shift; + + return { + totals => $self->totals, + source => $self->source, + }; +} + +sub summary { + my $self = shift; + my $totals = $self->totals; + + my $summary = ""; + for my $field (@TOTAL_FIELDS) { + my $hval = $totals->{"h_$field"} // next; + my $title = ucfirst($field); + + $summary .= " | " if $summary; + $summary .= "$title: $hval"; + } + + return $summary; +} + +sub table { + my $self = shift; + my $totals = $self->totals; + + my $table = { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [], + }; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + my $title = ucfirst($field); + + push @{$table->{rows}} => [$title, $hval, $val, $TOTAL_DESC{$field}]; + } + + return $table; +} + +sub job_fields { + my $self = shift; + my $totals = $self->totals; + + my @out; + + for my $field (@TOTAL_FIELDS) { + my $val = $totals->{$field} // next; + my $hval = $totals->{"h_$field"}; + + my $data = {}; + my $sources = $TOTAL_SOURCES{$field}; + for my $source (@$sources) { + $data->{$source} = { + stamp => $self->{$source}, + event_id => $self->{"${source}_id"}, + }; + } + + push @out => {name => "time_$field", details => $hval, raw => $val, data => $data}; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor::TimeTracker - Module that tracks timing data while an +event stream is processed. + +=head1 DESCRIPTION + +The timetracker module tracks timing data of an event stream. All events for a +given job should be run through a timetracker, which can then give data on how +long the test took in each of several stages. + +=over 4 + +=item startup - Time from launch to first test event. + +=item events - Time spent generating test events. + +=item cleanup - Time from last test event to test exit. + +=item total - Total time. + +=back + +=head1 SYNOPSIS + + use Test2::Harness::Auditor::TimeTracker; + + my $tracker = Test2::Harness::Auditor::TimeTracker->new(); + + my $assert_count = 0; + for my $event (@events) { + my $facet_data = $events->facet_data; + $assert_count++ if $facet_data->{assert}; + $tracker->process($event, $facet_data, $assert_count); + } + + print $tracker->summary; + # Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +=head1 METHODS + +=over 4 + +=item $tracker->process($event, $facet_data, $assert_count) + +=item $tracker->process($event, undef, $assert_count) + +TimeTracker builds its state from multiple events, each event should be +processed by this method. + +The second argument is optional, if no facet_data is provided it will pull the +facet_data from the event itself. This is mainly a micro-optimization to avoid +calling the C<facet_data()> method on the event multiple times if you have +already called it. + +=item $bool = $tracker->useful() + +Returns true if there is any useful data to display. + +=item $totals = $tracker->totals() + +Returns the totals like this: + + { + # Raw numbers + startup => ..., + events => ..., + cleanup => ..., + total => ..., + + # Human friendly versions + h_startup => ..., + h_events => ..., + h_cleanup => ..., + h_total => ..., + } + +=item $source = $tracker->source() + +This method returns the data from which the totals are derived. + + { + start => ..., # timestamp of the job starting + stop => ..., # timestamp of the job ending + first => ..., # timestamp of the first non-harness event + last => ..., # timestamp of the last non-harness event + + # These are event_id's of the events that provided the above stamps. + start_id => ..., + stop_id => ..., + first_id => ..., + last_id => ..., + complete_id => ..., + } + +=item $data = $tracker->data_dump + +This dumps the totals and source data: + + { + totals => $tracker->totals, + source => $tracker->source, + } + +=item $string = $tracker->summary + +This produces a summary string of the totals data: + + Startup: 0.00708s | Events: 0.00000s | Cleanup: 0.10390s | Total: 0.11098s + +Fields that have no data will be ommited from the string. + +=item $table = $tracker->table + +Returns this structure that is good for use in L<Term::Table>. + + { + header => ["Phase", "Time", "Raw", "Explanation"], + rows => [ + ['startup', $human_readible, $raw, "Time from launch to first test event."], + ['events', $human_radible, $raw, 'Time spent generating test events.'], + ['cleanup', $human_radible, $raw, 'Time from last test event to test exit.'], + ['total', $human_radible, $raw, 'Total time.'], + ], + } + +=item @items = $tracker->job_fields() + +This is used to obtain extra data to attach to the job completion event. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Auditor/Watcher.pm b/liby/Test2/Harness/Auditor/Watcher.pm new file mode 100644 index 000000000..7b730a740 --- /dev/null +++ b/liby/Test2/Harness/Auditor/Watcher.pm @@ -0,0 +1,488 @@ +package Test2::Harness::Auditor::Watcher; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; +use List::Util qw/first max/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util qw/hub_truth parse_exit/; + +use Test2::Harness::Auditor::TimeTracker; + +use Test2::Harness::Util::HashBase qw{ + -job + -try + + -assertion_count + -exit + -plan + -_errors + -_failures + -_sub_failures + -_plans + -_info + -_sub_info + -_subtest_id + -nested + -subtests + -numbers + -times + -halt + -failed_subtest_tree +}; + +sub init { + my $self = shift; + + croak "'job' is a required attribute" + unless $self->{+JOB}; + + croak "'try' is a required attribute" + unless defined $self->{+TRY}; + + $self->{+_FAILURES} = 0; + $self->{+_ERRORS} = 0; + $self->{+ASSERTION_COUNT} = 0; + + $self->{+NUMBERS} = {}; + $self->{+TIMES} = Test2::Harness::Auditor::TimeTracker->new(); + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; +} + +sub pass { !$_[0]->fail } +sub file { $_[0]->{+JOB}->{file} } +sub fail { !!$_[0]->fail_error_facet_list } + +sub has_exit { defined $_[0]->{+EXIT} } +sub has_plan { defined $_[0]->{+PLAN} } + +sub process { + my $self = shift; + my ($event) = @_; + + my $f = $event->{facet_data}; + my $hf = hub_truth($f); + + my $nested = $hf->{nested} || 0; + + $self->times->process($event, $f, $self->{+ASSERTION_COUNT}) unless $nested; + + return if $hf->{buffered}; + + my $is_ours = $nested == $self->{+NESTED}; + + return unless $is_ours || $f->{from_tap}; + + # Add parent if we start a buffered subtest + if ($f->{harness} && $f->{harness}->{subtest_start}) { + my $st = $self->{+SUBTESTS}->{$nested + 1} ||= {}; + $st->{event} = $event; + $f->{harness_watcher}->{no_render} = 1; + return; + } + + my @out; + + # Not actually a subtest end, someone printed to STDOUT + if ($f->{from_tap} && $f->{harness}->{subtest_end} && !($self->{+SUBTESTS} && keys %{$self->{+SUBTESTS}})) { + # Alter $f so that this incorrect event is not sent to the renderer. + $f->{harness_watcher}->{no_render} = 1; + + # Make a new $f and $event for the rest of the processing. + $f = { + %{$f}, + harness_watcher => {added_by_watcher => 1}, + parent => undef, + trace => undef, + harness => { + %{$f->{harness} || {}}, + subtest_end => undef, + }, + info => [ + @{$f->{info} || []}, + { + details => $f->{from_tap}->{details}, + tag => $f->{from_tap}->{source} || 'STDOUT', + from_harness => 1, + } + ], + }; + + $event = Test2::Harness::Event->new(stamp => time, job_try => $self->{+TRY}, facet_data => $f); + } + + push @out => $event; + + # Close any deeper subtests + if (my $sts = $self->{+SUBTESTS}) { + my @close = sort { $b <=> $a } grep { $_ > $nested } keys %$sts; + + for my $n (@close) { + my $st = delete $sts->{$n}; + my $se = $st->{event} || $event; + + my $fd = $se->{facet_data}; + delete $fd->{harness_watcher}->{no_render}; + $fd->{parent}->{hid} ||= $n; + $fd->{parent}->{children} ||= $st->{children}; + $fd->{harness}->{closed_by} = $event; + $fd->{harness}->{closed_by_eid} = $event->{event_id}; + + my $pn = $n - 1; + + if ($st->{event}) { + if ($pn > $self->{+NESTED}) { + push @{$sts->{$pn}->{children}} => $fd; + } + elsif ($pn == $self->{+NESTED}) { + $self->subtest_process($fd, $se); + push @out => $se; + } + } + else { + push @out => $se if $self->{+NESTED} && $pn == $self->{+NESTED}; + } + } + } + + unless ($is_ours) { + my $st = $self->{+SUBTESTS}->{$nested} ||= {}; + my $fd = {%$f}; + push @{$st->{children}} => $fd; + return @out; + } + + $self->subtest_process($f, $event); + return @out; +} + +sub subtest_process { + my $self = shift; + my ($f, $event) = @_; + + my $closer = delete $f->{harness}->{closed_by}; + $event ||= Test2::Harness::Event->new(facet_data => $f, job_try => $self->{+TRY}); + + $self->{+NUMBERS}->{$f->{assert}->{number}}++ + if $f->{assert} && $f->{assert}->{number}; + + if ($f->{parent} && $f->{assert}) { + my $name = $f->{assert}->{details} // "unnamed subtest ($f->{trace}->{frame}->[1] line $f->{trace}->{frame}->[2])"; + + my $subwatcher = blessed($self)->new(nested => $self->{+NESTED} + 1, job => $self->{+JOB}, try => $self->{+TRY}); + + my $id = 1; + for my $sf (@{$f->{parent}->{children}}) { + $sf->{harness}->{job_id} ||= $f->{harness}->{job_id}; + $sf->{harness}->{run_id} ||= $f->{harness}->{run_id}; + $sf->{harness}->{event_id} ||= $sf->{about}->{uuid} ||= gen_uuid(); + $subwatcher->subtest_process($sf); + } + + my @errors = $subwatcher->subtest_fail_error_facet_list(); + + if ($f->{harness}->{subtest_start}) { + push @{$f->{errors}} => {tag => 'REASON', fail => 1, from_harness => 1, details => "Buffered subtest ended abruptly (missing closing brace event)"} + unless $closer && $closer->{facet_data}->{harness}->{subtest_end}; + } + + my $fail = 0; + if (@errors) { + push @{$f->{errors}} => @errors; + $fail = 1; + } + else { + $fail ||= $f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}}); + $fail ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $fail ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + } + + if ($fail) { + $self->{+_SUB_FAILURES}++; + + # Populate the tree up to this subtest + my $tree = $self->{+FAILED_SUBTEST_TREE} //= []; + push @$tree => [$name, $subwatcher->{+FAILED_SUBTEST_TREE} // []]; + } + } + + $self->{+ASSERTION_COUNT}++ if $f->{assert}; + + if ($f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}})) { + $self->{+_FAILURES}++; + } + + if ($f->{control} || $f->{errors}) { + my $err ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); + $err ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; + $self->{+_ERRORS}++ if $err; + $self->{+HALT} = $f->{control}->{details} || '1' if $f->{control} && $f->{control}->{halt} && (!$self->{+HALT} || $self->{+HALT} eq '1'); + } + + if ($f->{plan} && !$f->{plan}->{none}) { + $self->{+_PLANS}++; + $self->{+PLAN} = $f->{plan}; + } + + if ($f->{harness_job_exit}) { + $self->{+EXIT} = $f->{harness_job_exit}->{exit}; + + my $file = $self->file(); + + my $end = $f->{harness_job_end} = { + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + retry => $f->{harness_job_exit}->{retry}, + fail => $self->fail(), + stamp => $f->{harness_job_exit}->{stamp}, + }; + + my $plan = $self->plan; + $end->{skip} = $plan->{details} || "No reason given" if $plan && !$plan->{count}; + + my $times = $self->times; + if ($times && $times->useful) { + $end->{times} = $times->data_dump; + push @{$f->{harness_job_fields}} => $times->job_fields; + push @{$f->{info}} => {tag => 'TIME', details => $times->summary, table => $times->table}; + } + + push @{$f->{errors}} => $self->fail_error_facet_list; + } + + return; +} + +sub subtest_fail_error_facet_list { + my $self = shift; + + return @{$self->{+_SUB_INFO}} if $self->{+_SUB_INFO}; + + my @out; + + my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; + my $count = $self->{+ASSERTION_COUNT}; + + my $numbers = $self->{+NUMBERS}; + my $max = max(keys %$numbers); + if ($max) { + for my $i (1 .. $max) { + if (!$numbers->{$i}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was never seen"}; + } + elsif ($numbers->{$i} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was seen more than once"}; + } + } + } + + if (!$self->{+_PLANS}) { + if ($count) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared"}; + } + else { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared, and no assertions were made."}; + } + } + elsif ($self->{+_PLANS} > 1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Too many plans were declared (Count: $self->{+_PLANS})"}; + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Planned for $plan assertions, but saw $self->{+ASSERTION_COUNT}"} + if $plan && $count != $plan; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Subtest failures were encountered (Count: $self->{+_SUB_FAILURES})"} + if $self->{+_SUB_FAILURES}; + + return @out; +} + +sub fail_error_facet_list { + my $self = shift; + + return @{$self->{+_INFO}} if $self->{+_INFO}; + + my @out; + + my $incomplete_subtests = values %{$self->{+SUBTESTS}}; + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "One or more incomplete subtests (Count: $incomplete_subtests)"} + if $incomplete_subtests; + + if (my $wstat = $self->{+EXIT}) { + if ($wstat == -1) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "The harness could not get the exit code! (Code: $wstat)"}; + } + else { + my $e = parse_exit($wstat); + if ($e->{err}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Err: $e->{err})"}; + } + if ($e->{sig}) { + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $e->{sig})"}; + } + } + } + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Errors were encountered (Count: $self->{+_ERRORS})"} + if $self->{+_ERRORS}; + + push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion failures were encountered (Count: $self->{+_FAILURES})"} + if $self->{+_FAILURES}; + + push @out => $self->subtest_fail_error_facet_list(); + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Auditor::Watcher - Class to monitor events for a single job and +pass judgement on the result. + +=head1 DESCRIPTION + +This module represents a per-job state tracker. This module sees every event +and manages the state produced. In the end this tracker determines if a test +job passed or failed, and why. + +=head1 SYNOPSIS + + use Test2::Harness::Auditor::Watcher; + + my $watcher = Test2::Harness::Auditor::Watcher->new(); + + for my $event (@events) { + $watcher->process($event); + } + + print "Pass!" if $watcher->pass; + print "Fail!" if $watcher->fail; + +=head1 METHODS + +=over 4 + +=item $int = $watcher->assertion_count() + +Number of assertions that have been seen. + +=item $exit = $watcher->exit() + +If the job has exited this will return the exit value (integer, 0 or greater). +If the job has not exited yet (or at least if the watcher has not seen the exit +event yet) this will return undef. + +=item $bool = $watcher->fail() + +Returns true if the job has failed/is failing. + +=item @error_facets = $watcher->fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $file = $watcher->file + +If the test file is known this will return it (string). This will return undef +if the file is not yet known. + +=item $string = $watcher->halt + +If the test was halted (bail-out) this will contain the human readible reason. + +=item $bool = $watcher->has_exit + +Check if the exit value is known. + +=item $bool = $watcher->has_plan + +Check if a plan has been seen. + +=item $job = $watcher->job + +If the job is known this will return the detailed structure of the job. + +=item $int = $watcher->nested + +If this watcher represents a subtest this will be an integer greater than 0, +the top-level test is 0. + +=item $hash = $watcher->numbers + +This is an internal state tracking what test numbers have been seen. This is +really only applicable in tests that produced TAP. + +=item $bool = $watcher->pass + +Check if the test job is passing. + +=item $plan_facet = $watcher->plan() + +If the plan facet has been seen this will return it. + +=item $watcher->process($event); + +Modify the state based on the provided event. + +=item $watcher->subtest_fail_error_facet_list + +Used internally to get a list of 'error' facets to inject into the +harness_job_exit event. + +=item $times = $watcher->times() + +Retuns the L<Test2::Harness::Auditor::TimeTracker> instance. + +=item $int = $watcher->try() + +Sometimes a job is run more than once, in those cases this will be an integer +greater than 0 representing the try. 0 is used for the first try. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Collector.pm b/liby/Test2/Harness/Collector.pm new file mode 100644 index 000000000..99c4cefca --- /dev/null +++ b/liby/Test2/Harness/Collector.pm @@ -0,0 +1,442 @@ +package Test2::Harness::Collector; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Collector::JobDir; +use Test2::Harness::State; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Time::HiRes qw/sleep time/; +use File::Spec; + +use File::Path qw/remove_tree/; + +use Test2::Harness::Util::HashBase qw{ + <run + <workdir + <run_id + <show_runner_output <truncate_runner_output <truncated_runner_output + <settings + <run_dir + <runner_pid +runner_exited <persistent_runner + + <backed_up + + +runner_stdout +runner_stderr +runner_aux_dir +runner_aux_handles + + +tasks_idx +tasks_done +tasks + +jobs_idx +jobs_done +jobs + +pending + + <wait_time + <action + <state +}; + +sub init { + my $self = shift; + + croak "'run' is required" + unless $self->{+RUN}; + + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + my $run_dir = File::Spec->catdir($self->{+WORKDIR}, $self->{+RUN_ID}); + die "Could not find run dir" unless -d $run_dir; + $self->{+RUN_DIR} = $run_dir; + + $self->{+WAIT_TIME} //= 0.02; + + $self->{+ACTION}->($self->_harness_event(0, undef, time, harness_run => $self->{+RUN}, harness_settings => $self->settings, about => {no_display => 1})); +} + +sub process { + my $self = shift; + + my %warning_seen; + my $settings = $self->settings; + + while (1) { + my $count = 0; + $count += $self->process_runner_output if $self->{+SHOW_RUNNER_OUTPUT}; + $count += $self->process_tasks(); + + my $jobs = $self->jobs; + + unless (keys %$jobs) { + next if $count; + + if ($self->persistent_runner) { + last if $self->{+JOBS_DONE}; + last if $self->runner_done; + } + + last if $self->runner_exited; + } + + while(my ($job_try, $jdir) = each %$jobs) { + $count++; + my $e_count = 0; + for my $event ($jdir->poll($self->settings->collector->max_poll_events // 1000)) { + $self->{+ACTION}->($event); + $e_count++; + } + + $count += $e_count; + next if $e_count; + my $done = $jdir->done; + unless ($done) { + $count++; + next; + } + + delete $jobs->{$job_try}; + unless ($settings->debug->keep_dirs) { + my $job_path = $jdir->job_root; + # Needed because we set the perms so that a tmpdir under it can be used. + # This is the only remove_tree that needs it because it is the + # only one in a process that did not initially create the dir. + my $ok = eval { + chmod(0700, $job_path); + remove_tree($job_path, {safe => 1, keep_root => 0}); + 1; + }; + my $err = $@; + unless ($ok) { + $count++; + unless ($warning_seen{$job_path}++) { + my $msg = "NON-FATAL Error deleting job dir ($job_path) will try again...: $err"; + my $e = $self->_harness_event(0, undef, time, info => [{details => $msg, tag => "INTERNAL", debug => 1, important => 1}]); + $self->{+ACTION}->($e); + } + next; + } + } + + delete $jobs->{$job_try}; + delete $self->{+PENDING}->{$jdir->job_id} unless $done->{retry}; + } + + last if !$count && $self->runner_exited; + sleep $self->{+WAIT_TIME} unless $count; + } + + # One last slurp + $self->process_runner_output if $self->{+SHOW_RUNNER_OUTPUT}; + + $self->{+ACTION}->(undef) if $self->{+JOBS_DONE} && $self->{+TASKS_DONE}; + + remove_tree($self->{+RUN_DIR}, {safe => 1, keep_root => 0}) unless $settings->debug->keep_dirs; + + return; +} + +sub runner_done { + my $self = shift; + + return 0 if keys %{$self->{+PENDING}}; + return 1; +} + +sub runner_exited { + my $self = shift; + my $pid = $self->{+RUNNER_PID} or return undef; + + return $self->{+RUNNER_EXITED} if $self->{+RUNNER_EXITED}; + + return 0 if kill(0, $pid); + + return $self->{+RUNNER_EXITED} = 1; +} + +sub process_runner_output { + my $self = shift; + + my $out = 0; + return $out unless $self->{+SHOW_RUNNER_OUTPUT}; + + my $action = $self->{+ACTION}; + if ($self->{+TRUNCATE_RUNNER_OUTPUT} && !$self->{+TRUNCATED_RUNNER_OUTPUT}) { + $action = sub {}; + $self->{+TRUNCATED_RUNNER_OUTPUT} = 1; + } + + my $stdout = $self->{+RUNNER_STDOUT} //= Test2::Harness::Util::File::Stream->new( + name => File::Spec->catfile($self->{+WORKDIR}, 'output.log'), + ); + + for my $line ($stdout->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => 'INTERNAL', important => 1}]); + $action->($e); + $out++; + } + + my $stderr = $self->{+RUNNER_STDERR} //= Test2::Harness::Util::File::Stream->new( + name => File::Spec->catfile($self->{+WORKDIR}, 'error.log'), + ); + + for my $line ($stderr->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => 'INTERNAL', debug => 1, important => 1}]); + $action->($e); + $out++; + } + + my $auxdir = $self->{+RUNNER_AUX_DIR} //= File::Spec->catdir($self->{+WORKDIR}, 'aux_logs'); + return $out unless -d $auxdir; + + opendir(my $dh, $auxdir) or die "Could not open aux_logs dir: $!"; + for my $path (readdir($dh)) { + next if $path =~ m/^\.+$/; + next if $self->{+RUNNER_AUX_HANDLES}->{$path}; + + my $tag = uc($path); + next unless $tag =~ s/\.LOG$//; + + my $debug = 0; + if ($tag =~ s/\W*(STDERR|STDOUT)\W*//g) { + $debug = 1 if $1 && uc($1) eq 'STDERR'; + } + + $self->{+RUNNER_AUX_HANDLES}->{$path} = { + tag => $tag, + debug => $debug, + stream => Test2::Harness::Util::File::Stream->new(name => File::Spec->catfile($auxdir, $path)), + }; + } + + for my $file (sort keys %{$self->{+RUNNER_AUX_HANDLES}}) { + my $data = $self->{+RUNNER_AUX_HANDLES}->{$file}; + my $stream = $data->{stream}; + + for my $line ($stream->poll()) { + chomp($line); + my $e = $self->_harness_event(0, undef, time, info => [{details => $line, tag => $data->{tag}, debug => $data->{debug}, important => 1}]); + $action->($e); + $out++; + } + } + + return $out; +} + +sub process_tasks { + my $self = shift; + + return 0 if $self->{+TASKS_DONE}; + + my $queue = $self->state->data->queue->{$self->{+RUN_ID}} or return 0; + my $idx = $self->{+TASKS_IDX} //= 0; + my $list = $queue->{list} // []; + + my $count = 0; + while (@$list > $idx) { + my $task = $list->[$idx++]; + $count++; + + my $job_id = $task->{job_id} or die "No job id!"; + $self->{+TASKS}->{$job_id} = $task; + $self->{+PENDING}->{$job_id} = 1 + ($task->{retry} || $self->run->retry || 0); + + my $e = $self->_harness_event($job_id, $task->{is_try} // 0, $task->{stamp}, 'harness_job_queued' => $task); + $self->{+ACTION}->($e); + } + + $self->{+TASKS_IDX} = $idx; + if ($queue->{closed}) { + $self->{+TASKS_DONE} = 1; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->queue->{$self->{+RUN_ID}}; + }); + } + + return $count; +} + +sub send_backed_up { + my $self = shift; + return if $self->{+BACKED_UP}++; + + # This is an unlikely code path. If we're here, it means the last loop couldn't process any results. + my $e = $self->_harness_event(0, undef, time, info => [{details => <<" EOT", tag => "INTERNAL", debug => 1, important => 1}]); +*** THIS IS NOT FATAL *** + + * The collector has reached the maximum number of concurrent jobs to process. + * Testing will continue, but some tests may be running or even complete before they are rendered. + * All tests and events will eventually be displayed, and your final results will not be effected. + +Set a higher --max-open-jobs collector setting to prevent this problem in the +future, but be advised that could result in too many open filehandles on some +systems. + +This message will only be shown once. + EOT + + $self->{+ACTION}->($e); + return; +} + +sub jobs { + my $self = shift; + + my $jobs = $self->{+JOBS} //= {}; + + return $jobs if $self->{+JOBS_DONE}; + + # Don't monitor more than 'max_open_jobs' or we might have too many open file handles and crash + # Max open files handles on a process applies. Usually this is 1024 so we + # can't have everything open at once when we're behind. + my $max_open_jobs = $self->settings->collector->max_open_jobs // 1024; + my $additional_jobs_to_parse = $max_open_jobs - keys %$jobs; + if($additional_jobs_to_parse <= 0) { + $self->send_backed_up; + return $jobs; + } + + my $idx = $self->{+JOBS_IDX} //= 0; + my $jdata = $self->{+STATE}->data->jobs->{$self->{+RUN_ID}} or return $jobs; + my $list = $jdata->{list} or return $jobs; + + while (@$list > $idx) { + my $job = $list->[$idx++]; + + my $job_id = $job->{job_id} or die "No job id!"; + + die "Found job without a task!" unless $self->{+TASKS}->{$job_id}; + + $self->{+PENDING}->{$job_id}--; + delete $self->{+PENDING}->{$job_id} if $self->{+PENDING}->{$job_id} < 1; + + my $file = $job->{file}; + my $e = $self->_harness_event( + $job_id, + $job->{is_try}, + $job->{stamp}, + + harness_job => $job, + + harness_job_start => { + details => "Job $job_id started at $job->{stamp}", + job_id => $job_id, + stamp => $job->{stamp}, + file => $file, + rel_file => File::Spec->abs2rel($file), + abs_file => File::Spec->rel2abs($file), + }, + harness_job_launch => { + stamp => $job->{stamp}, + retry => $job->{is_try}, + }, + ); + + $self->{+ACTION}->($e); + + my $job_try = $job_id . '+' . $job->{is_try}; + + $jobs->{$job_try} = Test2::Harness::Collector::JobDir->new( + job_try => $job->{is_try} // 0, + job_id => $job_id, + run_id => $self->{+RUN_ID}, + runner_pid => $self->{+RUNNER_PID}, + job_root => File::Spec->catdir($self->{+RUN_DIR}, $job_try), + ); + } + + $self->{+JOBS_IDX} = $idx; + + if ($jdata->{closed}) { + $self->{+JOBS_DONE} = 1; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->jobs->{$self->{+RUN_ID}}; + }); + } + + # The collector didn't read in all the jobs because it'd run out of file handles. We need to let the stream know we're behind. + $self->send_backed_up if $max_open_jobs <= keys %$jobs; + + return $jobs; +} + +sub _harness_event { + my $self = shift; + my ($job_id, $job_try, $stamp, %args) = @_; + + croak "Job id is required" unless defined $job_id; + croak "Stamp is required" unless defined $stamp; + + return Test2::Harness::Event->new( + stamp => $stamp, + job_id => $job_id, + job_try => $job_try, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => \%args, + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector - Module that collects test output and provides it as +an event stream. + +=head1 DESCRIPTION + +This module is responsible for reading and parsing the output produced by +multiple jobs running under yath. + +This module is not intended for external use, it is an implementation detail +and can change at any time. Currently instances of this module are not passed +to any plugins or callbacks. + +If you need a collector for a third-party command you should look at +L<App::Yath::Command::collector>. When a command needs a collector (such as +L<App::Yath::Command::test> does) it normally spawns a collector process by +execuing C<yath collector>. The C<start_collector()> subroutine in +L<App::Yath::Command::test> is a good place to look for more details. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Collector/JobDir.pm b/liby/Test2/Harness/Collector/JobDir.pm new file mode 100644 index 000000000..cab8cf7d3 --- /dev/null +++ b/liby/Test2/Harness/Collector/JobDir.pm @@ -0,0 +1,806 @@ +package Test2::Harness::Collector::JobDir; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Errno qw/EMFILE ENFILE/; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Util qw/ipc_separator/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/decode_json/; +use Test2::Harness::Util qw/maybe_read_file open_file apply_encoding/; + +use Test2::Harness::Event; + +use Test2::Harness::Util::File::Stream; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Value; + +use Test2::Harness::Collector::TapParser qw{ + parse_stdout_tap + parse_stderr_tap +}; + +use Test2::Harness::Util::HashBase qw{ + <run_id <job_id <job_try <job_root <runner_pid + <done + + -_ready_buffer + + -_events_files -_events_buffer -_events_indexes -events_dir -_events_seen + + -stderr_file -_stderr_buffer -_stderr_index -_stderr_cg -_stderr_state + -stdout_file -_stdout_buffer -_stdout_index -_stdout_cg -_stdout_state + + -exit_file -_exit_done -_exit_buffer + + -et_file -et_buffer -et_done + -pet_file -pet_buffer -pet_done + + -last_stamp + + -open_errors -open_error_seen +}; + +sub init { + my $self = shift; + + croak "'run_id' is a required attribute" + unless $self->{+RUN_ID}; + + croak "'job_id' is a required attribute" + unless $self->{+JOB_ID}; + + croak "'job_root' is a required attribute" + unless $self->{+JOB_ROOT}; + + $self->{+_EVENTS_SEEN} = {}; + + $self->{+_STDOUT_BUFFER} ||= []; + $self->{+_STDERR_BUFFER} ||= []; + $self->{+_EVENTS_BUFFER} ||= {}; + $self->{+_READY_BUFFER} ||= []; + + $self->{+LAST_STAMP} = time(); +} + +sub poll { + my $self = shift; + my ($max) = @_; + + delete $self->{+OPEN_ERRORS}; + + $self->_fill_buffers($max); + + return @{delete $self->{+OPEN_ERRORS}} if $self->{+OPEN_ERRORS}; + + my (@out, @new); + + # If we have a max number of events then we need to pass that along to the + # inner-pollers, but we need to pass around how many MORE we need, this sub + # will return the amount we still need. + # If this finds that we do not need any more it will exit the loop instead + # of returning a number. + my $check = defined($max) + ? sub { + my $want = $max - scalar(@out) - scalar(@new); + return undef if $want < 1; + return $want; + } + : sub { 1 }; + + while (!defined($max) || @out < $max) { + push @new => $self->_poll_streams($check->() // last); + + push @new => $self->_poll_timeouts($check->() // last) if $self->{+ET_BUFFER} || $self->{+PET_BUFFER}; + + # 'exit' MUST come last, so do not even think about grabbing + # them until @new is empty. + # Micro-optimization, 'exit' only ever has 1 thing, so do + # not enter the subs if we do not need to. + push @new => $self->_poll_exit($check->() // last) if !@new && defined $self->{+_EXIT_BUFFER}; + # We need to check if the runner exited BEFORE trying to check the exit value. + + last unless @new; + + push @out => @new; + @new = (); + } + + return map { + my $stamp = $_->{stamp} ? $self->{+LAST_STAMP} = $_->{stamp} : $self->{+LAST_STAMP}; + Test2::Harness::Event->new(stamp => $stamp, %{$_}); + } @out; +} + +sub _poll_streams { + my $self = shift; + my ($max) = @_; + + my $ready = $self->{+_READY_BUFFER}; + return splice(@$ready, 0, $max) unless @$ready < $max; + + my $stdout = $self->{+_STDOUT_BUFFER}; + my $stdout_cg = $self->{+_STDOUT_CG} ||= []; + my $stdout_params = { + buffer => $stdout, + comment_group => $stdout_cg, + tag => 'STDOUT', + debug => 0, + parser => \&parse_stdout_tap, + max => $max, + }; + + my $stderr = $self->{+_STDERR_BUFFER}; + my $stderr_cg = $self->{+_STDERR_CG} ||= []; + my $stderr_params = { + buffer => $stderr, + comment_group => $stderr_cg, + tag => 'STDERR', + debug => 1, + parser => \&parse_stderr_tap, + max => $max, + }; + + my $out_event = $self->_poll_stream($stdout_params); + my $err_event = $self->_poll_stream($stderr_params); + + # Once both stderr and stdout are waiting for an event we should go ahead + # and stick the events into ready. More often than not both streams will be + # waiting for the same event, the read_buffer_event logic will avoid + # duplicates. We want to call it on both buffers because some IPC + # situations can result in both streams waiting for different events. Also + # we need the sync point removed from both buffers so things can continue. + # This is an intentional bottle-neck that keeps STDOUT, STDERR, and the + # Test2 events in sync so that stderr and stdout appear where they should + # (mostly) relative to the events. This is not perfect, but it is as close + # as we can get when recombining 3+ output streams. + if ($out_event && $err_event) { + $self->_poll_streams_ready_buffer_event($stdout); + $self->_poll_streams_ready_buffer_event($stderr); + } + + if ($self->{+_EXIT_DONE} && (!$max || @$ready < $max)) { + # All done, flush the comment groups + $self->_poll_stream_flush_group($stdout_params) if @$stdout_cg; + $self->_poll_stream_flush_group($stderr_params) if @$stderr_cg; + + $self->_poll_streams_flush_events(); + } + + return splice(@$ready, 0, $max); +} + +sub _poll_streams_flush_events { + my $self = shift; + + my $buffers = $self->{+_EVENTS_BUFFER}; + for my $pid (keys %$buffers) { + for my $tid (keys %{$buffers->{$pid}}) { + my $buffer = $buffers->{$pid}->{$tid} or next; + while(my $e = shift @$buffer) { + $e = ref($e) ? $e : decode_json($e); + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); + } + } + } +} + +sub _poll_streams_ready_buffer_event { + my $self = shift; + my ($buffer) = @_; + + my $set = shift @$buffer; + my ($pid, $tid, $sid) = @$set; + + my $seen = $self->{+_EVENTS_SEEN}; + return if $seen->{$tid}->{$pid}->{$sid}; + + my $e = shift @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} or return; + $seen->{$tid}->{$pid}->{$sid} = 1; + + $e = ref($e) ? $e : decode_json($e); + + die "Stream error: Events skipped or recieved out of order ($e->{stream_id} != $sid)" + if $e->{stream_id} != $sid; + + push @{$self->{+_READY_BUFFER}} => $self->_process_events_line($e); +} + +sub _poll_stream_add_event { + my $self = shift; + my ($line, $params) = @_; + + my $parser = $params->{parser}; + my $tag = $params->{tag}; + my $debug = $params->{debug}; + + my $facet_data = $parser->($line); + $facet_data ||= {info => [{details => $line, tag => $tag, debug => $debug}]}; + my $event_id = $facet_data->{about}->{uuid} ||= gen_uuid(); + + push @{$self->{+_READY_BUFFER}} => { + facet_data => $facet_data, + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + }; +} + +sub _poll_stream_flush_group { + my $self = shift; + my ($params) = @_; + + my $comment_group = $params->{comment_group}; + + return unless @$comment_group; + + shift @$comment_group; # Remove the indentation state + + my $line = join "\n" => @$comment_group; + $self->_poll_stream_add_event($line, $params); + @$comment_group = (); +} + +sub _poll_stream_buffer_group { + my $self = shift; + my ($line, $params) = @_; + + return undef unless $line =~ m/^(\s*)#/; + my $indent = $1; + + my $comment_group = $params->{comment_group}; + + if (@$comment_group && $comment_group->[0] ne $indent) { + # If comment indentation has changed we do not want to append to the group + $self->_poll_stream_flush_group($params); + return 1; + } + else { + # Starting a new group + push @$comment_group => $indent; + } + + push @$comment_group => $line; + shift @{$params->{buffer}}; + return 0; +} + +sub _poll_stream { + my $self = shift; + my ($params) = @_; + + my $max = $params->{max}; + my $buff = $params->{buffer}; + my $comment_group = $params->{comment_group}; + + my $added = 0; + while (@$buff && (!$max || $added < $max)) { + my $line = $buff->[0]; + + # Already have an esync waiting + return 1 if ref $line; + + chomp($line); + + my $esync = $self->_poll_stream_process_harness_line($line, $params); + return 1 if $esync; + + # Put 'comment' lines together in a group, IE buffer this until we are done with comments + # get undef if there was no comment to buffer + # get 1 if we had to flush the buffer and start a new one + # get 0 if we did buffer the event, but no flush + my $stat = $self->_poll_stream_buffer_group($line, $params); + if (defined($stat)) { + $added += $stat; + next; + } + + # non-comment line, flush the comment group + if (@$comment_group) { + $self->_poll_stream_flush_group($params); + $added++; + next; + } + + shift @$buff; + $self->_poll_stream_add_event($line, $params); + $added++; + } + + return 0; +} + +sub _poll_stream_process_harness_line { + my $self = shift; + my ($line, $params) = @_; + + my $job_id = $self->{+JOB_ID}; + return undef unless $line =~ s/T2-HARNESS-\Q$job_id\E-(ESYNC|EVENT): (.+)//; + my ($type, $data) = ($1, $2); + + my $esync; + if ($type eq 'ESYNC') { + $esync = [split ipc_separator() => $data]; + } + elsif ($type eq 'EVENT') { + my $event_data = decode_json($data); + my $pid = $event_data->{pid}; + my $tid = $event_data->{tid}; + my $sid = $event_data->{stream_id}; + + push @{$self->{+_EVENTS_BUFFER}->{$pid}->{$tid}} => $event_data; + $esync = [$pid, $tid, $sid]; + } + else { + die "Unexpected harness type: $type"; + } + + # This becomes the esync, anything leftover actually belongs to the + # next line. + my $buff = $params->{buffer}; + $buff->[0] = $esync; + $buff->[1] = defined($buff->[1]) ? $line . $buff->[1] : $line if length $line; + + # Flush any comment group already buffered, an event is a sane + # boundary, not above that partial comments that might be + # interrupted by the sync point will be part of the next group + $self->_poll_stream_flush_group($params); + + return $esync; +} + +my %FILE_MAP = ( + 'stdout' => [STDOUT_FILE, \&open_file], + 'stderr' => [STDERR_FILE, \&open_file], + 'exit' => [EXIT_FILE, 'Test2::Harness::Util::File::Value'], + + 'event_timeout' => [ET_FILE, 'Test2::Harness::Util::File::Value'], + 'post_exit_timeout' => [PET_FILE, 'Test2::Harness::Util::File::Value'], +); + +sub _open_file { + my $self = shift; + my ($file) = @_; + + my $map = $FILE_MAP{$file} or croak "'$file' is not a known job file"; + my ($key, $type) = @$map; + + return $self->{$key} if $self->{$key}; + + my $path = File::Spec->catfile($self->{+JOB_ROOT}, $file); + my $out; + + if (ref $type) { + return undef unless -e $path; + return $self->{$key} = $self->try_open($path => sub { $type->($path, '<') }); + } + + return $self->{$key} = $self->try_open($path => sub { $type->new(name => $path) }); +} + +sub _fill_stream_buffers { + my $self = shift; + my ($max) = @_; + + my $stdout_state = $self->{+_STDOUT_STATE} //= {}; + my $stderr_state = $self->{+_STDERR_STATE} //= {}; + + my $stdout_buff = $self->{+_STDOUT_BUFFER} ||= []; + my $stderr_buff = $self->{+_STDERR_BUFFER} ||= []; + + my $stdout_file = $self->{+STDOUT_FILE} || $self->_open_file('stdout'); + my $stderr_file = $self->{+STDERR_FILE} || $self->_open_file('stderr'); + + return unless $stdout_file && $stderr_file; + + my @sets = grep { defined $_->[0] } ( + [$stdout_file, $stdout_buff, 'io', 'STDOUT', $stdout_state], + [$stderr_file, $stderr_buff, 'io', 'STDERR', $stderr_state], + ); + + return unless @sets; + + # Cache the result of the exists check on success, files can come into + # existence at any time though so continue to check if it fails. + while (1) { + my $added = 0; + my @events_files = $self->events_files(); + for my $set (@events_files, @sets) { + my ($file, $buff, $type, $name, $state) = @$set; + next if $max && @$buff > $max; + + my $pos = tell($file); + my $line = <$file>; + if (defined($line) && ($self->{+_EXIT_DONE} || substr($line, -1) eq "\n")) { + print "\n" if $state && delete $state->{$pos}; + + my $job_id = $self->{+JOB_ID}; + if ($type eq 'io' && $line =~ s/T2-HARNESS-\Q$job_id\E-ENCODING: (.+)\n$//) { + apply_encoding($file, $1); + } + + push @$buff => $line if length($line); + seek($file, 0, 1) if eof($file); # Reset EOF. + $added++; + } + else { + if ($name && defined($line) && $ENV{YATH_INTERACTIVE}) { + my ($fh); + + if ($name eq 'STDOUT') { + $fh = \*STDOUT; + } + elsif ($name eq 'STDERR') { + $fh = \*STDERR; + } + + my $len = length($line); + if (my $check = $state->{$pos}->{len}) { + if ($len != $check) { + delete $state->{$pos}->{done}; + $line = substr($line, $check); + } + else { + $line = "\n[INTERACTIVE] $line"; + } + } + else { + $line = "\n[INTERACTIVE] $line"; + } + + $state->{$pos}->{len} = $len; + + my $stamp = $state->{$pos}->{stamp} //= time; + my $delta = time - $stamp; + + if($delta >= 1 && !$state->{$pos}->{done}) { + $fh->autoflush(1); + + $state->{$pos}->{done} = 1; + print $fh $line; + } + } + seek($file, $pos, 0); + } + } + last unless $added; + } +} + +sub events_files { + my $self = shift; + + my $buff = $self->{+_EVENTS_BUFFER} ||= {}; + my $files = $self->{+_EVENTS_FILES} ||= {}; + + my $dir = File::Spec->catdir($self->{+JOB_ROOT}, 'events'); + return unless -d $dir; + + my $dh; + if ($self->try_open($dir => sub { opendir($dh, $dir) or die $! })) { + for my $file (readdir($dh)) { + next unless '.jsonl' eq substr($file, -6); + + next if $files->{$file}; + + my $path = File::Spec->catfile($dir, $file); + + next if $files->{$file}; + + my $fh = $self->try_open( + $path => sub { [ + split(ipc_separator() => substr(substr($file, 6 + length(ipc_separator())), 0, -6)), + open_file($path, '<'), + ] } + ); + + $files->{$file} = $fh if $fh; + } + } + + return map { [$_->[2] => $buff->{$_->[0]}->{$_->[1]} ||= [], 'jsonl'] } values %$files; +} + +sub try_open { + my $self = shift; + my ($path, $callback) = @_; + + local ($@, $?, $!, $.); + + my $out; + my $ok = eval { + $out = $callback->(); + 1; + }; + my $errno = $!; + my $err = $@; + + return $out if $ok; + + die $@ unless $errno == ENFILE || $errno == EMFILE; + + my $errors = $self->{+OPEN_ERRORS} //= []; + + unless ($self->{+OPEN_ERROR_SEEN}->{$path}++) { + push @$errors => Test2::Harness::Event->new( + stamp => time, + job_id => 0, + job_try => undef, + event_id => gen_uuid(), + run_id => $self->{+RUN_ID}, + facet_data => { + info => [{ + details => "Could not open '$path', this is NOT FATAL as yath will try again. Errno is '$errno', Exception was: $err", + tag => 'INTERNAL', + important => 1, + }], + } + ); + } + + return undef; +} + +sub _fill_buffers { + my $self = shift; + my ($max) = @_; + # NOTE 1: 'max' will only effect stdout, stderr, and events.jsonl, the + # other files only have 1 value each so they will not eat too much memory. + # + # NOTE 2: 'max' only effects how many items are ADDED to the buffer, not + # how many are in the buffer, that is good enough, poll() will take care of + # the actual event limiting. We only use this here to make sure the buffer + # grows slowly, this is important if max is used to avoid eating memory. We + # still need to add to the buffers each time though in case we are waiting + # for a sync event before we flush. + + # Wait for the directory + return unless -d $self->{+JOB_ROOT}; + + $self->_fill_stream_buffers($max); + + # Do not look for exit until we are done with the other streams + return if $self->{+_EXIT_DONE} || @{$self->{+_STDOUT_BUFFER}} || @{$self->{+_STDERR_BUFFER}} || first { @$_ } map { values %{$_} } values %{$self->{+_EVENTS_BUFFER}}; + + $self->_open_file('event_timeout'); + $self->_open_file('post_exit_timeout'); + + my $found_timeout = 0; + for my $set ([ET_FILE, ET_BUFFER], [PET_FILE, PET_BUFFER]) { + my ($key, $buffer_key) = @$set; + next if $self->{$buffer_key}; + next unless $self->{$key} && $self->{$key}->exists; + $self->{$buffer_key} = $self->{$key}->read_line // next; + $found_timeout++; + } + + return if $found_timeout; + + return if $self->{+OPEN_ERRORS}; + + my $ended = 0; + + # We need to check if the runner exited BEFORE trying to check the exit value. + my $runner_exited = $self->{+RUNNER_PID} && !kill(0, $self->{+RUNNER_PID}); + my $exit_file = $self->{+EXIT_FILE} || $self->_open_file('exit') || return; + return if $self->{+OPEN_ERRORS}; + + if ($exit_file->exists) { + my $line = $exit_file->read_line; + if (defined($line)) { + $self->{+_EXIT_BUFFER} = $line; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + } + elsif ($runner_exited) { + $self->{+_EXIT_BUFFER} = '-1'; + $self->{+_EXIT_DONE} = 1; + $ended++; + } + + return unless $ended; + + # If we found exit we need one last buffer fill on the other sources. + # If we do not do this we have a race condition. Ignore the max for this. + $self->_fill_stream_buffers(); +} + +sub _poll_timeouts { + my $self = shift; + + my @out; + + if (defined $self->{+ET_BUFFER} && !$self->{+ET_DONE}++) { + push @out => $self->_process_timeout_line('event' => $self->{+ET_BUFFER}, <<" EOT"); +Test2::Harness checks for timeouts at a configurable interval, if a test does +not produce any output to stdout or stderr between intervals it will be +forcefully killed under the assumption it has hung. See the '--event-timeout' +option to configure the interval. + EOT + } + + if (defined $self->{+PET_BUFFER} && !$self->{+PET_DONE}++) { + push @out => $self->_process_timeout_line('post-exit' => $self->{+ET_BUFFER}, <<" EOT"); +Sometimes tests will fork and then return. On supported systems Test2::Harness +will start all tests with their own process group and will wait for the entire +group to exit before considering the test done. In these cases Test2::Harness +will poll for output from the process group at a configurable interval, if no +output is produced between intervals the process group will be forcefully +killed. See the '--post-exit-timeout' option to configure the interval. + EOT + } + + return @out; +} + +sub _poll_exit { + my $self = shift; + # Intentionally ignoring the max argument, this only ever returns 1 item, + # and would not be called if max was 0. + + return unless defined $self->{+_EXIT_BUFFER}; + my $value = delete $self->{+_EXIT_BUFFER}; + + return $self->_process_exit_line($value); +} + +sub _process_events_line { + my $self = shift; + my ($event_data) = @_; + + $event_data->{job_id} = $self->{+JOB_ID}; + $event_data->{job_try} = $self->{+JOB_TRY}; + $event_data->{run_id} = $self->{+RUN_ID}; + $event_data->{event_id} ||= $event_data->{facet_data}->{about}->{uuid} ||= gen_uuid(); + + return $event_data; +} + +sub _process_exit_line { + my $self = shift; + my ($value) = @_; + + chomp($value); + + my $stdout = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stdout")); + my $stderr = maybe_read_file(File::Spec->catfile($self->{+JOB_ROOT}, "stderr")); + + $stdout =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + $stderr =~ s/T2-HARNESS-\S+-(?:ESYNC|EVENT): .+\n//g; + + my $event_id = gen_uuid(); + + my ($exit, $err, $sig, $dmp, $stamp, $retry) = (split(/\s+/, $value), '', '', '', '', '', ''); + + $self->{+DONE} = {retry => $retry}; + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id}, + harness_job_exit => { + details => "Test script exited $exit ($err\:$sig)", + exit => $exit, + code => $err, + signal => $sig, + dumped => $dmp, + retry => $retry, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + stdout => $stdout, + stderr => $stderr, + stamp => $stamp, + line => $value, + }, + } + }; +} + +sub _process_timeout_line { + my $self = shift; + my ($type, $buffer, $reason) = @_; + + chomp($buffer //= ''); + my ($stamp, $delta) = split /\s+/, $buffer; + $stamp //= time(); + $delta = defined($delta) ? sprintf('%.4f', $delta) : '??'; + + my $event_id = gen_uuid(); + + return { + event_id => $event_id, + job_id => $self->{+JOB_ID}, + job_try => $self->{+JOB_TRY}, + run_id => $self->{+RUN_ID}, + stamp => $stamp, + + facet_data => { + about => {uuid => $event_id, details => "Timeout ($type)"}, + errors => [ + { + tag => 'TIMEOUT', + details => "A timeout ($type) has occured (after $delta seconds), job was forcefully killed", + fail => 1, + }, + ], + info => [ + { + tag => 'TIMEOUT', + debug => 1, + important => 1, + details => $reason, + }, + ], + } + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::JobDir - Job Directory Parser, read events from an active +jobs output directory. + +=head1 DESCRIPTION + +This module is responsible for reading and parsing a running jobs output +directory. The result is an event stream. + +This module is not intended for external use, it is an implementation detail +and can change at any time. Currently instances of this module are not passed +to any plugins or callbacks. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Collector/TapParser.pm b/liby/Test2/Harness/Collector/TapParser.pm new file mode 100644 index 000000000..39520ef97 --- /dev/null +++ b/liby/Test2/Harness/Collector/TapParser.pm @@ -0,0 +1,383 @@ +package Test2::Harness::Collector::TapParser; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer 'Importer' => 'import'; + +our @EXPORT_OK = qw{ + parse_stdout_tap + parse_stderr_tap + parse_tap_line +}; + +sub parse_stdout_tap { + my ($line) = @_; + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{from_tap} = { source => 'STDOUT', details => $line }; + return $facet_data; +} + + +sub parse_stderr_tap { + my ($line) = @_; + + # STDERR only has comments + return unless $line =~ m/^\s*#/; + + my $facet_data = __PACKAGE__->_parse_tap_line($line) or return undef; + $facet_data->{info}->[-1]->{tag} = 'DIAG'; + $facet_data->{info}->[-1]->{debug} = 1; + $facet_data->{from_tap} = { source => 'STDERR', details => $line }; + + return $facet_data; +} + +sub parse_tap_line { + my ($line) = @_; + return __PACKAGE__->_parse_tap_line($line); +} + +sub _parse_tap_line { + my $class = shift; + my ($line) = @_; + chomp($line); + + my ($lead, $lead_len, $nest, $str) = ('', 0, 0, $line); + if ($line =~ m/^(\s+)\S/) { + $lead = $1; + $str =~ s/^\Q$lead\E//mg; + + $lead =~ s/\t/ /g; + $lead_len = length($lead); + + # indentation other than 0 or a multiple of 4 spaces... not an event + return undef if $lead_len % 4; + + $nest = $lead_len / 4; + } + + my @types = qw/buffered_subtest comment plan bail version/; + for my $type (@types) { + my $sub = "parse_tap_$type"; + my $facet_data = $class->$sub($str) or next; + $facet_data->{trace}->{nested} = $nest; + $facet_data->{hubs}->[0]->{nested} = $nest; + return $facet_data; + } + + return undef; +} + +sub parse_tap_buffered_subtest { + my $class = shift; + my ($line) = @_; + + # End of a buffered subtest. + return {parent => {}, harness => {subtest_end => 1}} if $line =~ m/^\}\s*$/; + + my $facet_data = $class->parse_tap_ok($line) or return undef; + return $facet_data unless $facet_data->{assert}->{details} =~ s/\s*\{\s*$//g; + + $facet_data->{parent} = { + details => $facet_data->{assert}->{details}, + }; + $facet_data->{harness}->{subtest_start} = 1; + + return $facet_data; +} + +sub parse_tap_ok { + my $class = shift; + my ($line) = @_; + + my ($pass, $todo, $skip, $num, @errors); + + return undef unless $line =~ s/^(not )?ok\b//; + $pass = !$1; + + push @errors => "'ok' is not immediately followed by a space." + if $line && !($line =~ m/^ /); + + if ($line =~ s/^(\s*)(\d+)\b//) { + my $space = $1; + $num = $2; + + push @errors => "Extra space after 'ok'" + if length($space) > 1; + } + + # Not strictly compliant, but compliant with what Test-Simple does... + # Standard does not have a todo & skip. + if ($line =~ s/#\s*(todo & skip|todo|skip)(.*)$//i) { + my ($directive, $reason) = ($1, $2); + + push @errors => "No space before the '#' for the '$directive' directive." + unless $line =~ s/\s+$//; + + push @errors => "No space between '$directive' directive and reason." + if $reason && !($reason =~ s/^\s+//); + + $skip = $reason if $directive =~ m/skip/i; + $todo = $reason if $directive =~ m/todo/i; + } + + # Standard says that everything after the ok (except the number) is part of + # the name. Most things add a dash between them, and I am deviating from + # standards by stripping it and surrounding whitespace. + $line =~ s/\s*-\s*//; + + $line =~ s/^\s+//; + $line =~ s/\s+$//; + + my $is_subtest = ($line =~ m/^Subtest:\s*(.*)$/) ? ($1 or 1) : undef; + + my $facet_data = { + assert => { + pass => $pass, + no_debug => 1, + details => $line, + defined $num ? (number => $num) : (), + }, + }; + + $facet_data->{parent} = { + details => $is_subtest, + } if defined $is_subtest; + + push @{$facet_data->{amnesty}} => { + tag => 'SKIP', + details => $skip, + } if defined $skip; + + push @{$facet_data->{amnesty}} => { + tag => 'TODO', + details => $todo, + } if defined $todo; + + push @{$facet_data->{info}} => { + details => $_, + debug => 1, + tag => 'PARSER', + } for @errors; + + return $facet_data; +} + +sub parse_tap_version { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^TAP version\s/; + + return { + about => { + details => $line, + }, + info => [ + { + tag => 'INFO', + debug => 0, + details => $line, + } + ], + }; +} + +sub parse_tap_plan { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ s/^1\.\.(\d+)//; + my $max = $1; + + my ($directive, $reason) = ("", ""); + + if ($max == 0) { + if ($line =~ s/^\s*#\s*//) { + if ($line =~ s/^(skip)\S*\s*//i) { + $directive = uc($1); + $reason = $line; + $line = ""; + } + } + + $directive ||= "SKIP"; + $reason ||= "no reason given"; + } + + my $facet_data = { + plan => { + count => $max, + skip => ($directive eq 'SKIP') ? 1 : 0, + details => $reason, + } + }; + + push @{$facet_data->{info}} => { + details => 'Extra characters after plan.', + debug => 1, + tag => 'PARSER', + } if $line =~ m/\S/; + + return $facet_data; +} + +sub parse_tap_bail { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^Bail out!\s*(.*)$/; + + return { + control => { + halt => 1, + details => $1, + } + }; +} + +sub parse_tap_comment { + my $class = shift; + my ($line) = @_; + + return undef unless $line =~ m/^\s*#/; + + $line =~ s/^\s*# ?//msg; + + return { + info => [ + { + details => $line, + tag => 'NOTE', + debug => 0, + } + ] + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Collector::TapParser - Produce EventFacets from a line of TAP. + +=head1 DESCRIPTION + +This module is responsible for reading and processing any TAP output from +tests. Lines of TAP output are processed into L<Test2::Event> facet data. Note +that C<< Test2 -> TAP -> Test2 >> is lossy at the C<< Test2 -> TAP >> step. + +=head1 SYNOPSIS + + use Test2::Harness::Collector::TapParser qw/parse_tap_line/; + + my $facet_data = parse_tap_line("1..1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + plan => { + details => '', + count => 1, + skip => 0, + }, + }, + "Parsed the plan" + ); + + $facet_data = parse_tap_line("# foo"); + is( + $facet_data, + { + trace => { nested => 0 }, + hubs => [ { nested => 0 } ], + info => [ + { + tag => 'NOTE', + details => 'foo', + debug => 0, + }, + ], + }, + + "Parsed the note" + ); + + $facet_data = parse_tap_line("ok 1"); + is( + $facet_data, + { + trace => {nested => 0}, + hubs => [{nested => 0}], + assert => { + no_debug => 1, + pass => 1, + number => '1', + details => '', + }, + }, + "Parsed the assertion" + ); + +=head1 EXPORTS + +=over 4 + +=item $facet_data = parse_tap_line($line) + +Parse a line of TAP. It is assumed to be STDOUT thus all comments are turned +into notes. Using this export will B<NOT> add the usual C<from_tap> facet. It +is better to use one of the other 2 exports. + +=item $facet_data = parse_stdout_tap($line) + +Parse a line of TAP from stdout. + +=item $facet_data = parse_stderr_tap($line) + +Parse a line of TAP from stderr. This will B<ONLY> parse comment lines (ones +that start with a C<#>, which may be indented). All comments will be treated as +diag's, all other lines will be ignored. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Event.pm b/liby/Test2/Harness/Event.pm new file mode 100644 index 000000000..5f207ce2d --- /dev/null +++ b/liby/Test2/Harness/Event.pm @@ -0,0 +1,216 @@ +package Test2::Harness::Event; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util::JSON qw/encode_json/; + +use Importer 'Test2::Util::Facets2Legacy' => ':ALL'; + +BEGIN { + require Test2::Event; + our @ISA = ('Test2::Event'); + + # Currently the base class for events does not have init(), that may change + if (Test2::Event->can('init')) { + *INIT_EVENT = sub() { 1 } + } + else { + *INIT_EVENT = sub() { 0 } + } +} + +use Test2::Harness::Util::HashBase qw{ + <facet_data + <stream_id + <event_id + <run_id + <job_id + <job_try + <stamp + +json + processed +}; + +sub trace { $_[0]->{+FACET_DATA}->{trace} } +sub set_trace { confess "'trace' is a read only attribute" } + +sub init { + my $self = shift; + + $self->Test2::Event::init() if INIT_EVENT; + + my $data = $self->{+FACET_DATA} || confess "'facet_data' is a required attribute"; + + for my $field (RUN_ID(), JOB_ID(), JOB_TRY(), EVENT_ID()) { + my $v1 = $self->{$field}; + my $v2 = $data->{harness}->{$field}; + + my $d1 = defined($v1); + my $d2 = defined($v2); + + confess "'$field' is a required attribute" + unless $d1 || $d2 || ($field eq +JOB_TRY && !$self->{+JOB_ID}); + + confess "'$field' has different values between attribute and facet data" + if $d1 && $d2 && $v1 ne $v2; + + $self->{$field} = $data->{harness}->{$field} = $v1 // $v2; + } + + delete $data->{facet_data}; + + # Original trace wins. + if (my $trace = delete $self->{+TRACE}) { + $self->{+FACET_DATA}->{trace} //= $trace; + } +} + +sub as_json { $_[0]->{+JSON} //= encode_json($_[0]) } + +sub TO_JSON { + my $out = {%{$_[0]}}; + + $out->{+FACET_DATA} = { %{$out->{+FACET_DATA}} }; + delete $out->{+FACET_DATA}->{harness_job_watcher}; + delete $out->{+FACET_DATA}->{harness}->{closed_by}; + delete $out->{+JSON}; + delete $out->{+PROCESSED}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Event - Subclass of Test2::Event used by Test2::Harness under +the hood. + +=head1 DESCRIPTION + +Test2 tests produce a sequence of events objects L<Test2::Event>. This is a +subclass of those events for use in L<Test2::Harness>. Event non-test tests +which produce TAP output will have the output parsed into these types of +events. + +=head1 SYNOPSIS + +In normal usage ou will never need to create one fo these events yourself. This +documentation assumes you are operating on an existing event C<$event> that the +harness exposed to you via a plugin or similar. + + my $facet_data = $event->facet_data; + my $run_id = $event->run_id; + my $job_id = $event->job_id; + my $job_try = $event->job_try; + my $event_id = $event->event_id; + +=head1 METHODS + +See L<Test2::Event> for methods provided by the base class. + +=over 4 + +=item $hashref = $event->TO_JSON + +Used for json serialization. + +=item $json_string = $event->as_json + +This will return a json representation of the event. Note that this is a lossy +conversion with some harness specific state removed by design. This may even be +a cached copy of the json string that was decoded to produce the original +object. If the string was not cached before it will be cached for all future +calls ignoring any state change to the event. + +The lossy/cached conversion is intended so that events get passed through the +harness pipeline without modifications from one step translating to another. If +you need something extra to go through you need to either replace the event or +create an additional one. + +=item $string = $event->event_id + +Usually a UUID, but not always! + +=item i$hashref = $event->facet_data + +Get the event facet data, this is the meat of the event that hold all the +state. + +=item $string = $event->job_id + +Usually a UUID, but not always! + +=item $int = $event->job_try + +Integer, 0 or greater. Some jobs are run additional times if they fail, this +says which attempt the event is for. The counter starts at 0. + +=item $bool = $event->processed + +This will be true if the event has been process by the harness. Note that this +attibute is not serialized by C<TO_JSON> or C<as_json>. + +=item $string = $event->run_id + +The run id. This is usually a UUID, but not always! + +=item $ts = $event->stamp + +A unix timestamp for when the event was created. + +=item $id = $event->stream_id + +This is an implementation detail of L<Test2::Formatter::Stream>, do not rely on +it. This is used to prevent parsing errors when stream output is nested in +other stream output, which can happen if you are writing tests for the stream +formatter itself. + +=item $trace = $event->trace + +This si a shortcut for C<< $event->facet_data->{trace} >>. The trace data is +essential and used everywhere. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Finder.pm b/liby/Test2/Harness/Finder.pm new file mode 100644 index 000000000..093dd8f93 --- /dev/null +++ b/liby/Test2/Harness/Finder.pm @@ -0,0 +1,940 @@ +package Test2::Harness::Finder; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util qw/clean_path mod2file/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; +use List::Util qw/first/; +use Cwd qw/getcwd/; +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Text::ParseWords qw/quotewords/; + +use Test2::Harness::TestFile; +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <default_search <default_at_search + + <durations <maybe_durations +duration_data <durations_threshold + + <exclude_files <exclude_patterns <exclude_lists + + <no_long <only_long + + <rerun <rerun_modes <rerun_plugin + + search <extensions + + <multi_project + + <changed <changed_only <changes_plugin <show_changed_files <changes_diff + <changes_filter_file <changes_filter_pattern + <changes_exclude_file <changes_exclude_pattern + <changes_include_whitespace <changes_exclude_nonsub + <changes_exclude_loads <changes_exclude_opens +}; + +sub munge_settings {} + +sub init { + my $self = shift; + + $self->{+EXCLUDE_FILES} = { map {( $_ => 1 )} @{$self->{+EXCLUDE_FILES}} } if ref($self->{+EXCLUDE_FILES}) eq 'ARRAY'; + + if (my $plugins = $self->{+RERUN_PLUGIN}) { + for (@$plugins) { + $_ = "App::Yath::Plugin::$_" unless s/^\+// or m/^(App::Yath|Test2::Harness)::Plugin::/; + my $file = mod2file($_); + require $file; + } + } +} + +sub duration_data { + my $self = shift; + my ($plugins, $settings, $test_files) = @_; + + $self->{+DURATION_DATA} //= $self->pull_durations(); + + return $self->{+DURATION_DATA} if $self->{+DURATION_DATA}; + + for my $plugin (@$plugins) { + next unless $plugin->can('duration_data'); + $self->{+DURATION_DATA} = $plugin->duration_data($settings, $test_files) or next; + last; + } + + return $self->{+DURATION_DATA} //= {}; +} + +sub pull_durations { + my $self = shift; + + my $primary = delete $self->{+MAYBE_DURATIONS}; + my $fallback = delete $self->{+DURATIONS}; + + my @args = ( + name => 'durations', + is_json => 1, + http_args => [{headers => {'Content-Type' => 'application/json'}}], + ); + + if ($primary) { + local $@; + + my $durations = eval { $self->_pull_from_file_or_url(source => $primary, @args) } + or print "Could not fetch optional durations '$primary', ignoring...\n"; + + if ($durations) { + print "Found durations: $primary\n"; + return $durations; + } + } + + return $self->_pull_from_file_or_url(source => $fallback, @args) + if $fallback; + + return; +} + +sub add_exclusions_from_lists { + my $self = shift; + + my @lists = ref($self->{+EXCLUDE_LISTS}) eq 'ARRAY' ? @{$self->{+EXCLUDE_LISTS}} : ($self->{+EXCLUDE_LISTS}); + + for my $path (@lists) { + my $content = $self->_pull_from_file_or_url( + source => $path, + name => 'exclusion lists', + ); + + next unless $content; + + for (split(/\r?\n\r?/, $content)) { + $self->{+EXCLUDE_FILES}->{$_} = 1 unless /^\s*#/; + }; + } +} + +sub _pull_from_file_or_url { + my $self = shift; + my %params = @_; + + my $in = $params{source} // croak "No file or url provided"; + my $name = $params{name} // croak "No name provided"; + + my $is_json = $params{is_json}; + + if (my $type = ref($in)) { + return $in if $is_json && ($type eq 'HASH' || $type eq 'ARRAY'); + } + elsif (-f $in) { + if ($is_json) { + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => $in); + return $file->read(); + } + else { + require Test2::Harness::Util::File; + my $f = Test2::Harness::Util::File->new(name => $in); + return $f->read(); + } + } + elsif ($in =~ m{^https?://}) { + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args}; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + my $res = $ht->$meth($in, $args ? (@$args) : ()); + + die "Could not query $name from '$in'\n$res->{status}: $res->{reason}\n$res->{content}\n" + unless $res->{success}; + + return $is_json ? decode_json($res->{content}) : $res->{content}; + } + + die "Invalid $name specification: $in"; +} + +sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + $self->add_exclusions_from_lists() if $self->{+EXCLUDE_LISTS}; + + my $add_changes = 0; + $add_changes ||= $self->{+CHANGED} && @{$self->{+CHANGED}}; + $add_changes ||= $self->{+CHANGED_ONLY}; + $add_changes ||= $self->{+CHANGES_PLUGIN}; + $add_changes ||= $self->{+CHANGES_DIFF}; + + $self->add_changed_to_search($plugins, $settings) if $add_changes; + + my $add_rerun = $self->{+RERUN}; + $self->add_rerun_to_search($plugins, $settings, $add_rerun) if $add_rerun; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + + return $self->find_project_files($plugins, $settings, $self->search); +} + +sub check_plugins { + my $self = shift; + my ($plugins, $settings) = @_; + + my $check_plugins = $plugins; + my $plugin; + if (my $p = $self->{+CHANGES_PLUGIN}) { + $plugin = $p =~ s/^\+// ? $p : "App::Yath::Plugin::$p"; + $check_plugins = [$plugin]; + } + + return $check_plugins // []; +} + +sub get_diff { + my $self = shift; + my ($plugins, $settings) = @_; + + return (file => $self->{+CHANGES_DIFF}) if $self->{+CHANGES_DIFF}; + + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + if ($plugin->can('changed_diff')) { + my ($type, $data) = $plugin->changed_diff($settings); + next unless $type && $data; + + return ($type => $data); + } + } + + return (); +} + +sub find_changes { + my $self = shift; + my ($plugins, $settings) = @_; + + my @listed_changes = @{$self->{+CHANGED}} if $self->{+CHANGED}; + + my ($type, $diff) = $self->get_diff($plugins, $settings); + + my (@found_changes); + if ($type && $diff) { + @found_changes = $self->changes_from_diff($type => $diff, $settings); + } + + unless (@found_changes) { + my $check_plugins = $self->check_plugins($plugins, $settings); + + for my $plugin (@$check_plugins) { + next unless $plugin->can('changed_files'); + + push @found_changes => $plugin->changed_files($settings); + last if @found_changes; + } + } + + my $filter_patterns = @{$self->{+CHANGES_FILTER_PATTERN}} ? $self->{+CHANGES_FILTER_PATTERN} : undef; + my $filter_files = @{$self->{+CHANGES_FILTER_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_FILTER_FILE}}} : undef; + + my $exclude_patterns = @{$self->{+CHANGES_EXCLUDE_PATTERN}} ? $self->{+CHANGES_EXCLUDE_PATTERN} : undef; + my $exclude_files = @{$self->{+CHANGES_EXCLUDE_FILE}} ? {map { $_ => 1 } @{$self->{+CHANGES_EXCLUDE_FILE}}} : undef; + + my %changed_map; + for my $change (@listed_changes, @found_changes) { + next unless $change; + my ($file, @parts) = ref($change) ? @$change : ($change); + + next if $filter_files && !$filter_files->{$file}; + next if $exclude_files && $exclude_files->{$file}; + next if $filter_patterns && !first { $file =~ m/$_/ } @$filter_patterns; + next if $exclude_patterns && first { $file =~ m/$_/ } @$exclude_patterns; + + @parts = ('*') unless @parts; + $changed_map{$file}{$_} = 1 for @parts; + } + + return \%changed_map; +} + +sub get_capable_plugins { + my $self = shift; + my ($method, $plugins) = @_; + + my %seen; + return grep { $_ && !$seen{$_}++ && $_->can($method) } @$plugins; +} + +sub add_rerun_to_search { + my $self = shift; + my ($plugins, $settings, $rerun) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $modes = $self->{+RERUN_MODES}; + my $mode_hash = { map {$_ => 1} @$modes }; + + my ($grabbed, $data); + for my $p ($self->get_capable_plugins(grab_rerun => [@{$self->{+RERUN_PLUGIN} // []}, @$plugins])) { + ($grabbed, $data) = $p->grab_rerun($rerun, modes => $modes, mode_hash => $mode_hash, settings => $settings); + next unless $grabbed; + + unless ($data && keys %$data) { + print "No files found to rerun.\n"; + exit 0; + } + + last if $grabbed; + } + + unless ($grabbed) { + if ($rerun eq '1') { + $rerun = first { -e $_ } qw{ ./lastlog.jsonl ./lastlog.jsonl.bz2 ./lastlog.jsonl.gz }; + + die "Could not find a lastlog.jsonl(.bz2|.gz) file for re-running, you may need to provide a full path to --rerun=... or --rerun-failed=..." + unless $rerun; + } + + die "'$rerun' is not a valid log file, and no plugin intercepted it.\n" unless -f $rerun; + + my $stream = Test2::Harness::Util::File::JSONL->new(name => $rerun, skip_bad_decode => 1); + + my %files; + while (1) { + my @events = $stream->poll(max => 1000) or last; + + for my $event (@events) { + my $f = $event->{facet_data} or next; + + for my $type (qw/seen queued start end/) { + my $field = $type eq 'seen' ? "harness_job" : "harness_job_$type"; + + my $data = $f->{$field} or next; + + my $file = $data->{rel_file} // $data->{run_file} // $data->{file} // $data->{abs_file}; + next unless $file; + + my $ref = $files{$file} //= {}; + $ref->{$type}++; + + $ref->{$data->{fail} ? 'fail' : 'pass'}++ if $type eq 'end'; + $ref->{retry}++ if $data->{is_try}; + } + } + } + + $data = \%files; + } + + my @add = map { $data->{$_}->{add} // $_ } grep { + my $entry = $data->{$_}; + + my $keep = $mode_hash->{all} ? 1 : 0; + $keep ||= 1 if $mode_hash->{failed} && $entry->{fail} && !$entry->{pass}; + $keep ||= 1 if $mode_hash->{retried} && $entry->{retry}; + $keep ||= 1 if $mode_hash->{passed} && $entry->{pass}; + $keep ||= 1 if $mode_hash->{missed} && !$entry->{end}; + + $keep + } sort keys %$data; + + unless (@add) { + print "No files found to rerun.\n"; + exit 0; + } + + push @$search => @add; +} + +sub add_changed_to_search { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search; + unless ($search) { + $search = []; + $self->set_search($search); + } + + my $changed_map = $self->find_changes($plugins, $settings); + my $found_changed = keys %$changed_map; + + die "Could not find any changed files.\n" if $self->{+CHANGED_ONLY} && !$found_changed; + + if ($self->{+CHANGED_ONLY}) { + die "Can not add test or directory names when using --changed-only (saw: " . join(", " => @$search) . ")\n" + if @$search; + } + + if ($self->{+SHOW_CHANGED_FILES} && $found_changed) { + print "Found the following changed files:\n"; + for my $file (keys %$changed_map) { + print " $file: ", join(", ", sort keys %{$changed_map->{$file}}), "\n"; + } + } + + my @add; + for my $p ($self->get_capable_plugins(get_coverage_tests => $plugins)) { + for my $set ($p->get_coverage_tests($settings, $changed_map)) { + my $test = ref($set) ? $set->[0] : $set; + + unless (-e $test) { + print STDERR "Coverage wants to run test '$test', but it does not exist, skipping...\n"; + next; + } + + push @add => $set; + } + } + + for my $p ($self->get_capable_plugins(post_process_coverage_tests => $plugins)) { + $p->post_process_coverage_tests($settings, \@add); + } + + if ($self->{+SHOW_CHANGED_FILES} && @add) { + print "Found " . scalar(@add) . " test files to run based on changed files.\n"; + print ref($_) ? " $_->[0]" : " $_\n" for @add; + print "\n"; + } + + push @$search => @add; + + return; +} + +sub changes_from_diff { + my $self = shift; + my ($type, $data, $settings) = @_; + + my $next; + if ($type eq 'lines') { + $next = sub { shift @$data }; + } + elsif ($type eq 'diff') { + my $lines = [split /\n/, $data]; + $next = sub { shift @$lines }; + } + elsif ($type eq 'file') { + die "'$data' is not a valid diff file.\n" unless -f $data; + open(my $fh, '<', $data) or die "Could not open diff file '$data': $!"; + $next = sub { + my $line = <$fh>; + close($fh) unless defined $line; + return $line; + }; + } + elsif ($type eq 'line_sub') { + $next = $data; + } + elsif ($type eq 'handle') { + $next = sub { scalar <$data> }; + } + else { + die "Invalid diff type '$type'"; + } + + my %changed; + + # Only perl can parse perl, and nothing can parse perl diff. What this does + # is take a diff of every file with 100% context so we see the entire file + # with the +, minus, or space prefix. As we scan it we look for subs. We + # track what files and subs we are in. When we see a change we + # {$file}{$sub}++. + # + # This of course is broken if you make a change between + # subs as it will attribute it to the previous sub, however tracking + # indentation is equally flawed as things like heredocs and other special + # perl things can also trigger that to prematurely think we are out of a + # sub. + # + # PPI and similar do a better job parsing perl, but using them and also + # tracking changes from the diff, or even asking them to parse a diff where + # some lines are added and others removed is also a huge hassle. + # + # The current algorith is "good enough", not perfect. + my ($file, $sub, $indent, $is_perl); + while (my $line = $next->()) { + chomp($line); + if ($line =~ m{^(?:---|\+\+\+) ([ab]/)?(.*)$}) { + my $maybe_prefix = $1; + my $maybe_file = $2; + next if $maybe_file =~ m{/dev/null}; + if ($maybe_prefix) { + $file = -f "$maybe_prefix$maybe_file" ? "$maybe_prefix$maybe_file" : $maybe_file; + } + else { + $file = $maybe_file; + } + $is_perl = 1 if $file =~ m/\.(pl|pm|t2?)$/; + $sub = '*'; # Wildcard, changes to the code outside of a sub potentially effects all subs + next; + } + + next unless $file; + + $line =~ m/^( |-|\+)(.*)$/ or next; + my ($prefix, $statement) = ($1, $2); + my $changed = $prefix eq ' ' ? 0 : 1; + + $is_perl = 1 if $statement =~ m/^#!.*perl/; + + if ($statement =~ m/^(\s*)sub\s+(\w+)/) { + $indent = $1 // ''; + $sub = $2; + + # 1-line sub: sub foo { ... } + if ($statement =~ m/}/) { + $changed{$file}{$sub}++ if $changed; + $sub = '*'; + $indent = undef; + next; + } + } + elsif(defined($indent) && $statement =~ m/^$indent\}/) { + $indent = undef; + $sub = "*"; + + # If this is nothing but whitespace and a closing paren we can skip it. + next if $statement =~ m/^\s*\}?\s*$/ && !$self->{+CHANGES_INCLUDE_WHITESPACE}; + } + + next unless $sub; # If sub is empty then we are not even in a file yet + next unless $changed; # If we are not on a changed line no need to add it + unless ($self->{+CHANGES_INCLUDE_WHITESPACE}) { + next if !length($statement); # If there is no statement length then this is whitespace only + next if $statement =~ m/^\s+$/; # Do not care about whitespace only changes + } + + next if $is_perl && $self->{+CHANGES_EXCLUDE_NONSUB} && $sub eq '*'; + + $changed{$file}{$sub}++; + } + + return map {([$_ => sort keys %{$changed{$_}}])} sort keys %changed; +} + + +sub find_multi_project_files { + my $self = shift; + my ($plugins, $settings) = @_; + + my $search = $self->search // []; + + die "multi-project search must be a single directory, or the current directory" if @$search > 1; + my ($pdir) = @$search; + my $dir = clean_path(getcwd()); + + my $out = []; + my $ok = eval { + chdir($pdir) if defined $pdir; + my $ret = clean_path(getcwd()); + + opendir(my $dh, '.') or die "Could not open project dir: $!"; + for my $subdir (readdir($dh)) { + chdir($ret); + + next if $subdir =~ m/^\./; + my $path = clean_path(File::Spec->catdir($ret, $subdir)); + next unless -d $path; + + chdir($path) or die "Could not chdir to $path: $!\n"; + + for my $item (@{$self->find_project_files($plugins, $settings, [])}) { + push @{$item->queue_args} => ('ch_dir' => $path); + push @$out => $item; + } + } + + chdir($ret); + 1; + }; + my $err = $@; + + chdir($dir); + die $err unless $ok; + + return $out; +} + +sub find_project_files { + my $self = shift; + my ($plugins, $settings, $input) = @_; + + $input //= []; + $plugins //= []; + + my $default_search = [@{$self->default_search}]; + push @$default_search => @{$self->default_at_search} if $settings->check_prefix('run') && $settings->run->author_testing; + + $_->munge_search($input, $default_search, $settings) for @$plugins; + + my $search = @$input ? $input : $self->{+CHANGED_ONLY} ? [] : $default_search; + + die "No tests to run, search is empty\n" unless @$search; + + + my (%seen, @tests, @dirs); + + for my $item (@$search) { + my ($path, $test_params); + + if (ref $item) { + ($path, $test_params) = @$item; + } + else { + my ($type, $data); + ($path, $type, $data) = split /(:<|:@|:=)/, $item, 2; + if ($type && $data) { + $test_params = {}; + if ($type eq ':<') { + $test_params->{stdin} = $data; + } + elsif ($type eq ':@') { + $test_params->{argv} = decode_json($data); + } + elsif ($type eq ':=') { + $test_params->{env} = decode_json($data); + } + } + } + + push @dirs => $path and next if -d $path; + + unless(-f $path) { + my ($actual, $args) = split /=/, $path, 2; + if (-f $actual) { + $path = $actual; + $test_params = {%{$test_params // {}}, argv => [quotewords('\s+', 0, $args)]}; + } + else { + die "'$path' is not a valid file or directory.\n" if @$input; + next; + } + } + + $path = clean_path($path, 0); + $seen{$path}++; + + my $test; + unless (first { $test = $_->claim_file($path, $settings, from => 'listed') } @$plugins) { + $test = Test2::Harness::TestFile->new(file => $path); + } + + if (my @exclude = $self->exclude_file($test)) { + if (@$input) { + print STDERR "File '$path' was listed on the command line, but has been exluded for the following reasons:\n"; + print STDERR " $_\n" for @exclude; + } + + next; + } + + if ($test_params) { + $test->set_input($test_params->{stdin}) if $test_params->{stdin}; + $test->set_test_args($test_params->{argv}) if $test_params->{argv}; + $test->set_env_vars($test_params->{env}) if $test_params->{env}; + } + + push @tests => $test; + } + + if (@dirs) { + require File::Find; + File::Find::find( + { + no_chdir => 1, + wanted => sub { + no warnings 'once'; + + my $file = clean_path($File::Find::name, 0); + + return if $seen{$file}++; + return unless -f $file; + + my $test; + unless(first { $test = $_->claim_file($file, $settings, from => 'search') } @$plugins) { + for my $ext (@{$self->extensions}) { + next unless m/\.\Q$ext\E$/; + $test = Test2::Harness::TestFile->new(file => $file); + last; + } + } + + return unless $test; + return unless $self->include_file($test); + push @tests => $test; + }, + }, + @dirs + ); + } + + my $test_count = @tests; + my $threshold = $settings->finder->durations_threshold // 0; + if ($threshold && $test_count >= $threshold) { + my $start = time; + my $durations = $self->duration_data($plugins, $settings, [map { $_->relative } @tests]); + my $end = time; + if ($durations && keys %$durations) { + printf("Fetched duration data (Took %0.2f seconds)\n", $end - $start); + for my $test (@tests) { + my $rel = $test->relative; + $test->set_duration($durations->{$rel}) if $durations->{$rel}; + } + } + } + + $_->munge_files(\@tests, $settings) for @$plugins; + + return [ sort { $a->rank <=> $b->rank || $a->file cmp $b->file } @tests ]; +} + +sub include_file { + my $self = shift; + my ($test) = @_; + + my @exclude = $self->exclude_file($test); + + return !@exclude; +} + +sub exclude_file { + my $self = shift; + my ($test) = @_; + + my @out; + + push @out => "File has a do-not-run directive inside it." unless $test->check_feature(run => 1); + + my $full = $test->file; + my $rel = $test->relative; + + push @out => 'File is in the exclude list.' if $self->exclude_files->{$full} || $self->exclude_files->{$rel}; + push @out => 'File matches an exclusion pattern.' if first { $rel =~ m/$_/ } @{$self->exclude_patterns}; + + push @out => 'File is marked as "long", but the "no long tests" opition was specified.' + if $self->no_long && $test->check_duration eq 'long'; + + push @out => 'File is not marked "long", but the "only long tests" option was specified.' + if $self->only_long && $test->check_duration ne 'long'; + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Finder - Library that searches for test files + +=head1 DESCRIPTION + +The finder is responsible for locating test files that should be run. You can +subclass the finder and instruct yath to use your subclass. + +=head1 SYNOPSIS + +=head2 USING A CUSTOM FINDER + +To use Test2::Harness::Finder::MyFinder: + + $ yath test --finder MyFinder + +To use Another::Finder + + $ yath test --finder +Another::Finder + +By default C<Test2::Harness::Finder::> is prefixed onto your custom finder, use +'+' before the class name or prevent this. + +=head2 SUBCLASSING + + use parent 'Test2::Harness::Finder'; + use Test2::Harness::TestFile; + + # Custom finders may provide their own options if desired. + # This is optional. + use App::Yath::Options; + option foo => ( + ... + ); + + # This is the main method to override. + sub find_project_files { + my $self = shift; + my ($plugins, $settings, $search) = @_; + + return [ + Test2::Harness::TestFile->new(...), + Test2::Harness::TestFile->new(...), + ..., + ]; + } + +=head1 METHODS + +These are important state methods, as well as utility methods for use in your +subclasses. + +=over 4 + +=item $bool = $finder->multi_project + +True if the C<yath projects> command was used. + +=item $arrayref = $finder->find_files($plugins, $settings) + +This is the main method. This method returns an arrayref of +L<Test2::Harness::TestFile> instances, each one representing a single test to +run. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +B<Note:> In many cases it is better to override C<find_project_files()> in your +subclasses. + +=item $durations = $finder->duration_data + +This will fetch the durations data if any was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +B<Note:> The result is cached, see L<pull_durations()> to refresh the data. + +=item @reasons = $finder->exclude_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This will +return a list of human readible reasons a test file should be excluded. If the +file should not be excluded the list will be empty. + +This is a utility method that verifies the file is not in an exclude +list/pattern. The reasons are provided back in case you need to inform the +user. + +=item $bool = $finder->include_file($test) + +The input argument should be an L<Test2::Harness::Test> instance. This is a +convenience method around C<exclude_file()>, it will return true when +C<exclude_file()> returns an empty list. + +=item $arrayref = $finder->find_multi_project_files($plugins, $settings) + +=item $arrayref = $finder->find_project_files($plugins, $settings, $search) + +These do the heavy lifting for C<find_files> + +The default C<find_files()> implementation is this: + + sub find_files { + my $self = shift; + my ($plugins, $settings) = @_; + + return $self->find_multi_project_files($plugins, $settings) if $self->multi_project; + return $self->find_project_files($plugins, $settings, $self->search); + } + +Each one returns an arrayref of L<Test2::Harness::TestFile> instances. + +Note that C<find_multi_project_files()> uses C<find_project_files()> internall, +once per project directory. + +$plugins is a list of plugins, some may be class names, others may be +instances. + +$settings is an L<Test2::Harness::Settings> instance. + +$search is an arrayref of search paths. + +=item $finder->munge_settings($settings, $options) + +A callback that lets you munge settings and options. + +=item $finder->pull_durations + +This will fetch the durations data if ant was provided. This is a hashref of +relative test paths as keys where the value is the duration of the file (SHORT, +MEDIUM or LONG). + +L<duration_data()> is a cached version of this. This method will refresh the +cache for the other. + +=back + +=head2 FROM SETTINGS + +See L<App::Yath::Options::Finder> for up to date documentation on these. + +=over 4 + +=item $finder->default_search + +=item $finder->default_at_search + +=item $finder->durations + +=item $finder->maybe_durations + +=item $finder->exclude_files + +=item $finder->exclude_patterns + +=item $finder->no_long + +=item $finder->only_long + +=item $finder->search + +=item $finder->extensions + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/IPC.pm b/liby/Test2/Harness/IPC.pm new file mode 100644 index 000000000..4129c9ee1 --- /dev/null +++ b/liby/Test2/Harness/IPC.pm @@ -0,0 +1,520 @@ +package Test2::Harness::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use POSIX; + +use Config qw/%Config/; +use Carp qw/croak confess/; +use Time::HiRes qw/sleep time/; + +use Test2::Harness::Util::IPC qw/run_cmd USE_P_GROUPS/; + +use Test2::Harness::IPC::Process; + +BEGIN { + my %SIG_MAP; + my @SIGNAMES = split /\s+/, $Config{sig_name}; + my @SIGNUMS = split /\s+/, $Config{sig_num}; + while (@SIGNAMES) { + $SIG_MAP{shift(@SIGNAMES)} = shift @SIGNUMS; + } + + *SIG_MAP = sub() { \%SIG_MAP }; +} + +use Test2::Harness::Util::HashBase qw{ + <pid + <handlers + <procs + <procs_by_cat + <waiting + <wait_time + <started + <sig_count +}; + +sub init { + my $self = shift; + + $self->{+PID} = $$; + + $self->{+PROCS} //= {}; + $self->{+PROCS_BY_CAT} //= {}; + + $self->{+WAIT_TIME} = 0.02 unless defined $self->{+WAIT_TIME}; + + $self->{+HANDLERS} //= {}; + $self->{+HANDLERS}->{CHLD} //= sub { 1 }; + + $self->{+SIG_COUNT} //= 0; +} + +sub start { + my $self = shift; + + my @caller = caller(1); + + return if $self->{+STARTED}; + $self->{+STARTED} = 1; + + $self->check_for_fork(); + + for my $sig (qw/INT HUP TERM CHLD/) { + croak "Signal '$sig' was already set by something else" + if defined $SIG{$sig} + && $SIG{$sig} ne 'IGNORE' + && $SIG{$sig} ne 'DEFAULT'; + $SIG{$sig} = sub { $self->handle_sig($sig) }; + } +} + +sub stop { + my $self = shift; + + $self->wait(all => 1); + + delete $SIG{$_} for qw/INT HUP TERM CHLD/; + + $self->{+STARTED} = 0; +} + +sub set_sig_handler { + my $self = shift; + my ($sig, $sub) = @_; + $self->{+HANDLERS}->{$sig} = $sub; +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + $self->{+SIG_COUNT}++ unless $sig eq 'CHLD'; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->stop(); + exit(SIG_MAP->{$sig}); +} + +sub killall { + my $self = shift; + my ($sig) = @_; + $sig //= 'TERM'; + + $self->check_for_fork(); + + kill($sig, keys %{$self->{+PROCS}}); +} + +sub check_timeouts {} + +sub check_for_fork { + my $self = shift; + + return 0 if $self->{+PID} == $$; + + $self->{+PROCS} = {}; + $self->{+PROCS_BY_CAT} = {}; + $self->{+WAITING} = {}; + $self->{+PID} = $$; + + return 1; +} + +sub _bring_out_yer_dead { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + # Wait on any/all pids + my $found = 0; + while ((my $pid = waitpid(-1, WNOHANG)) > 0) { + my $exit = $?; + die "waitpid returned pid '$pid', but we are not monitoring that one!" unless $procs->{$pid}; + $found++; + $waiting->{$pid} = [$exit, time()]; + } + + return $found; +} + +sub _check_if_dead_yet { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$waiting) { + next if USE_P_GROUPS && kill(0, -$pid); + $found++; + my $args = delete $waiting->{$pid}; + my $proc = delete $procs->{$pid}; + delete $cat_procs->{$proc->category}->{$pid}; + $self->set_proc_exit($proc, @$args); + } + + return $found; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, @args) = @_; + $proc->set_exit($self, @args); +} + +sub _ex_parrots { + my $self = shift; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + my $found = 0; + for my $pid (keys %$procs) { + next if $waiting->{$pid}; + next if kill(0, $pid); + $found++; + warn "Process $pid vanished!"; + $waiting->{$pid} = [-1, time()]; + } + + return $found; +} + +sub wait { + my $self = shift; + my %params = @_; + + $self->check_for_fork(); + + my $sig_count = $self->{+SIG_COUNT}; + + my $procs = $self->{+PROCS} //= {}; + my $cat_procs = $self->{+PROCS_BY_CAT} //= {}; + my $waiting = $self->{+WAITING} //= {}; + + return 0 unless keys(%$procs) || keys(%$waiting); + + my $cat_total = $params{cat} ? keys %{$cat_procs->{$params{cat}}} : 0; + + my $start = time; + + my $count = 0; + my $found = 0; + while (1) { + $self->check_timeouts; + + $found += $self->_bring_out_yer_dead(); + $found += $self->_check_if_dead_yet(); + + return $found if $self->_wait_done($found, $start, \%params); + + if (my $cat = $params{cat}) { + my $cur_total = keys %{$cat_procs->{$cat}}; + return 0 unless $cur_total; + my $delta = $cat_total - $cur_total; + return $delta if $delta; + } + + # This is expensive, so only do it if we are gonna end up waiting + # anyway If we do find anything here do not bother waiting. + next if $self->_ex_parrots(); + + # Break the loop if we had a signal come in since starting + last if $self->{+SIG_COUNT} > $sig_count; + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "We escaped the wait cycle"; + return $found; +} + +sub _wait_done { + my $self = shift; + my ($found, $start, $params) = @_; + + my $all = keys(%{$self->{+PROCS}}); + return 1 unless $all; + + return 1 if $params->{timeout} && time - $start >= $params->{timeout}; + + return 0 if $all && $params->{all}; + + return 0 if $params->{all_cat} && keys %{$self->{+PROCS_BY_CAT}->{$params->{all_cat}}}; + + return 0 if $params->{block} && !$found; + + # This gets validated outside this loop + return 0 if $params->{cat}; + + return 1; +} + +sub watch_pid { + my $self = shift; + my ($pid) = @_; + + my $proc = Test2::Harness::IPC::Process->new(pid => $pid); + + return $self->watch($proc); +} + +sub watch { + my $self = shift; + my ($proc) = @_; + + $self->check_for_fork(); + + my $pid = $proc->pid or confess "Process has no pid"; + $pid = abs($pid) if USE_P_GROUPS; + + croak "Already watching pid $pid" if exists $self->{+PROCS}->{$pid}; + + $self->{+PROCS}->{$pid} = $proc; + $self->{+PROCS_BY_CAT}->{$proc->category}->{$pid} = $proc; +} + +sub spawn { + my $self = shift; + my ($proc, $params); + if (@_ == 1) { + $proc = shift(@_); + $params = $proc->spawn_params; + } + else { + $params = {@_}; + my $class = $params->{process_class} // 'Test2::Harness::IPC::Process'; + $proc = $class->new(); + } + + croak "No 'command' specified" unless $params->{command}; + + my $caller1 = [caller()]; + my $caller2 = [caller(1)]; + + my $env = $params->{env_vars} // {}; + + $self->check_for_fork(); + + my $pid = run_cmd(env => $env, caller1 => $caller1, caller2 => $caller2, %$params); + $proc->set_pid($pid); + + $self->watch($proc); + return $proc; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC - Base class for modules that control child processes. + +=head1 DESCRIPTION + +This module is the base class for all parts of L<Test2::Harness> that have to +do process management. + +=head1 ATTRIBUTES + +=over 4 + +=item $pid = $ipc->pid + +The root PID of the IPC object. + +=item $hashref = $ipc->handlers + +Custom signal handlers specific to the IPC object. + +=item $hashref = $ipc->procs + +Hashref of C<< $pid => $proc >> where $proc is an instance of +L<Test2::Harness::IPC::Proc>. + +=item $hashref = $ipc->procs_by_cat + +Hashref of C<< $category => { $pid => $proc } >>. + +=item $hashref = $ipc->waiting + +Hashref of processes that have finished, but have not been handled yet. + +This is an implementation detail you should not rely on. + +=item $float = $ipc->wait_time + +How long to sleep between loops when in a wait cycle. + +=item $bool = $ipc->started + +True if the IPC process has started. + +=item $ipc->sig_count + +Implementation detail, used to break wait loops when signals are received. + +=back + +=head1 METHODS + +=over 4 + +=item $ipc->start + +Start the IPC management (Insert signal handlers). + +=item $ipc->stop + +Stop the IPC management (Remove signal handlers). + +=item $ipc->set_sig_handler($sig, sub { ... }) + +Set a custom signal handler. This is a safer version of +C<< local %SIG{$sig} >> for use with IPC. + +The callback will get exactly one argument, the name of the signal that was +recieved. + +=item $ipc->handle_sig($sig) + +Handle the specified signal. Will cause process exit if the signal has no +handler. + +=item $ipc->killall() + +=item $ipc->killall($sig) + +Kill all tracked child process with the given signal. C<TERM> is used if no +signal is specified. + +This will not wait on the processes, you must call C<< $ipc->wait() >>. + +=item $ipc->check_timeouts + +This is a no-op on the IPC base class. This is called every loop of +C<< $ipc->wait >>. If you subclass the IPC class you can fill this in to make +processes timeout if needed. + +=item $ipc->check_for_fork + +This is used a lot internally to check if this is a forked process. If this is +a forked process the IPC object is completely reset with no remaining internal +state (except signal handlers). + +=item $ipc->set_proc_exit($proc, @args) + +Calls C<< $proc->set_exit(@args) >>. This is called by C<< $ipc->wait >>. You +can override it to add custom tasks when a process exits. + +=item $int = $ipc->wait() + +=item $int = $ipc->wait(%params) + +Wait on processes, return the number found. + +Default is non-blocking. + +Options: + +=over 4 + +=item timeout => $float + +If a blocking paremeter is provided this can be used to break the wait after a +timeout. L<Time::HiRes> is used, so timeout is in seconds with decimals. + +=item all => $bool + +Block until B<ALL> processes are done. + +=item cat => $category + +Block until at least 1 process from the category is complete. + +=item all_cat => $category + +Block until B<ALL> processes from the category are complete. + +=item block => $bool + +Block until at least 1 process is complete. + +=back + +=item $ipc->watch($proc) + +Add a process to be monitored. + +=item $proc = $ipc->spawn($proc) + +=item $proc = $ipc->spawn(%params) + +In the first form $proc is an instance of L<Test2::Harness::IPC::Proc> that +provides C<spawn_params()>. + +In the second form the following params are allowed: + +Anything supported by C<run_cmd()> in L<Test2::Harness::Util::IPC>. + +=over 4 + +=item process_class => $CLASS + +Default is L<Test2::Harness::IPC::Process>. + +=item command => $command + +Program command to call. This is required. + +=item env_vars => { ... } + +Specify custom environment variables for the new process. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/IPC/Model.pm b/liby/Test2/Harness/IPC/Model.pm new file mode 100644 index 000000000..c42d6a2d5 --- /dev/null +++ b/liby/Test2/Harness/IPC/Model.pm @@ -0,0 +1,48 @@ +package Test2::Harness::IPC::Model; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util::HashBase qw{ + <state <pid <run_id +}; + +sub init { + my $self = shift; + + $self->{+PID} //= $$; + croak "'state' is required" unless $self->{+STATE}; + croak "'run_id' is required" unless $self->{+RUN_ID}; +} + +sub establish_interactive_stdin { + my $self = shift; + + my $fh; + + if (my $fifo = $ENV{YATH_INTERACTIVE}) { + open($fh, '<', $fifo) or die "Could not open fifo '$fifo': $!"; + } + elsif (-t STDIN) { + $fh = \*STDIN; + } + else { + confess "No human input source is available"; + } + + return $fh; +} + +sub get_test_stdout_pair { croak(blessed($_[0]) . '->get_test_stdout_pair() is not implemented') } +sub get_test_stderr_pair { croak(blessed($_[0]) . '->get_test_stderr_pair() is not implemented') } +sub get_test_events_pair { croak(blessed($_[0]) . '->get_test_events_pair() is not implemented') } +sub add_renderer { croak(blessed($_[0]) . '->add_renderer() is not implemented') } +sub render_event { croak(blessed($_[0]) . '->render_event() is not implemented') } + +sub finish {} + +1; diff --git a/liby/Test2/Harness/IPC/Model/AtomicPipe.pm b/liby/Test2/Harness/IPC/Model/AtomicPipe.pm new file mode 100644 index 000000000..0eb71c011 --- /dev/null +++ b/liby/Test2/Harness/IPC/Model/AtomicPipe.pm @@ -0,0 +1,198 @@ +package Test2::Harness::IPC::Model::AtomicPipe; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; +use POSIX qw/mkfifo/; +use File::Path qw/make_path/; + +use File::Spec; +use Atomic::Pipe; + +use Test2::Util qw/get_tid/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +pair_cache + +renderer_writers +}; + +sub _get_mixed_pair { + my $self = shift; + + my ($r, $w) = Atomic::Pipe->pair(mixed_data_mode => 1); + + $r->resize($r->max_size); + $w->resize($w->max_size); + $w->wh->autoflush(1); + + my %out; + + my (@lines, @data); + my $read = sub { + if ($w) { + $w->close(); + $w = undef; + delete $out{write_ap}; + } + + while (1) { + my ($type, $val) = $r->get_line_burst_or_data; + last unless $type; + + if ($type eq 'message') { + push @data => decode_json($val); + } + elsif ($type eq 'line') { + push @lines => $val; + } + else { + die "Invalid type '$type'"; + } + } + }; + + my $read_line = sub { $read->(); my @out = @lines; @lines = (); return @out }; + my $read_data = sub { $read->(); my @out = @data; @data = (); return @out }; + + %out = ( + read_line => $read_line, + read_data => $read_data, + read_ap => $r, + write_ap => $w, + ); + + return \%out; +} + +sub get_test_stdout_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + return ($bits->{read_line}, $bits->{write_ap}->wh()); +} + +sub get_test_stderr_pair { + my $self = shift; + my ($r, $w) = Atomic::Pipe->pair; + $r->resize($r->max_size); + my $rh = $r->rh; + $rh->blocking(0); + $w->resize($w->max_size); + $w->wh->autoflush(1); + return (sub { <$rh> }, $w->wh()); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $bits = $self->{+PAIR_CACHE}->{$job_id}->{$job_try} //= $self->_get_mixed_pair; + + my $writer_sub = sub { + if ($bits->{read_ap}) { + $bits->{read_ap}->close(); + delete $bits->{read_ap}; + delete $bits->{read_line}; + delete $bits->{read_data}; + } + + $bits->{write_ap}->write_message(encode_json($_)) for @_; + }; + + return ($bits->{read_data}, $writer_sub); +} + +sub add_renderer { + my $self = shift; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, 'renderers'); + make_path($path) unless -d $path; + + # Create file for fifo + my $id = gen_uuid(); + my $file = File::Spec->catfile($path, "${id}.fifo"); + + # make fifo + mkfifo($file, 0700) or die "Failed to create fifo"; + + my $r = Atomic::Pipe->read_fifo($file); + $r->resize($r->max_size); + $r->blocking(0); + + # add the fifo to state for future writers + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + my $files = $data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} //= []; + push @$files => $file; + }); + + # return a sub to read the fifo + return sub { + my @out; + while (my $msg = $r->read_message) { + push @out => decode_json($msg); + } + return @out; + }; +} + +sub renderer_writers { + my $self = shift; + + if (my $have = $self->{+RENDERER_WRITERS}) { + return @{$have->{list} //= []} if $have->{pid} == $$ && $have->{tid} == get_tid(); + delete $self->{+RENDERER_WRITERS}; + delete $_->{out_buffer} for @{$have->{list} // []}; + } + + my @list; + for my $ap (@{$self->{+STATE}->data->ipc_model->{render_pipes}->{$self->{+RUN_ID}} // []}) { + my $w = Atomic::Pipe->write_fifo($ap); + $w->resize($w->max_size); + push @list => $w; + } + + $self->{+RENDERER_WRITERS} = { + pid => $$, + tid => get_tid(), + list => \@list, + }; + + return @list; +} + +sub render_event { + my $self = shift; + my ($e) = @_; + + my $json = encode_json($e); + + $_->write_message($json) for $self->renderer_writers; +} + +sub finish { + my $self = shift; + # Blocking flush on all/any renderer handles + + # First flush any that can be flushed without a wait + $_->flush(blocking => 0) for $self->renderer_writers; + + # Terminate the output + $self->render_event(undef); + + # Now we wait and flush all. + for my $ap ($self->renderer_writers) { + $ap->flush(blocking => 1); + $ap->close(); + } +} + +1; diff --git a/liby/Test2/Harness/IPC/Model/FilePipeHybrid.pm b/liby/Test2/Harness/IPC/Model/FilePipeHybrid.pm new file mode 100644 index 000000000..7f8870900 --- /dev/null +++ b/liby/Test2/Harness/IPC/Model/FilePipeHybrid.pm @@ -0,0 +1,56 @@ +package Test2::Harness::IPC::Model::FilePipeHybrid; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use Test2::Harness::IPC::Model::Files; +use Test2::Harness::IPC::Model::AtomicPipe; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + -files + -pipes +}; + +sub init { + my $self = shift; + + $self->{+FILES} //= Test2::Harness::IPC::Model::Files->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); + $self->{+PIPES} //= Test2::Harness::IPC::Model::AtomicPipe->new(state => $self->{+STATE}, run_id => $self->{+RUN_ID}); +} + +sub get_test_stdout_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stdout_pair(@_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->{+PIPES}->get_test_stderr_pair(@_); +} + +sub get_test_events_pair { + my $self = shift; + return $self->{+PIPES}->get_test_events_pair(@_); +} + +sub add_renderer { + my $self = shift; + $self->{+FILES}->add_renderer(@_); +} + +sub render_event { + my $self = shift; + $self->{+FILES}->render_event(@_); +} + +sub finish { + my $self = shift; + $self->{+FILES}->finish(@_); + $self->{+PIPES}->finish(@_); +} + +1; diff --git a/liby/Test2/Harness/IPC/Model/Files.pm b/liby/Test2/Harness/IPC/Model/Files.pm new file mode 100644 index 000000000..9851cac3f --- /dev/null +++ b/liby/Test2/Harness/IPC/Model/Files.pm @@ -0,0 +1,149 @@ +package Test2::Harness::IPC::Model::Files; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Carp qw/croak confess/; + +use File::Spec; +use File::Path qw/make_path/; + +use Test2::Util qw/get_tid ipc_separator/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; +use Test2::Harness::Util::File::JSONL; +use Test2::Harness::Util::File::Stream; + +use parent 'Test2::Harness::IPC::Model'; +use Test2::Harness::Util::HashBase qw{ + +render_writer +}; + +sub get_test_stdout_pair { + my $self = shift; + return $self->_get_std_pair(STDOUT => @_); +} + +sub get_test_stderr_pair { + my $self = shift; + return $self->_get_std_pair(STDERR => @_); +} + +sub _get_std_pair { + my $self = shift; + my ($fname, $job_id, $job_try) = @_; + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, $job_id, $job_try); + + make_path($path) unless -d $path; + + my $file = File::Spec->catfile($path, $fname); + + open(my $wh, '>>', $file) or die "Could not open '$file' for writing: $!"; + + my $rs; + my $read_sub = sub { + $rs //= Test2::Harness::Util::File::Stream->new(name => $file); + $rs->poll(); + }; + + return ($read_sub, $wh); +} + +sub get_test_events_pair { + my $self = shift; + my ($job_id, $job_try) = @_; + + my $reader_sub = $self->_generate_reader(event_files => $job_id, $job_try); + my $writer_sub = $self->_generate_writer(event_files => $job_id, $job_try); + + return ($reader_sub, $writer_sub); +} + +sub add_renderer { + my $self = shift; + return $self->_generate_reader('render_files'); +} + +sub render_event { + my $self = shift; + my ($e) = @_; + my $writer = $self->{+RENDER_WRITER} //= $self->_generate_writer('render_files'); + $writer->($e); +} + +sub _generate_writer { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, $stream, $file) = (0, 0); + my $writer_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + $file = File::Spec->catfile($path, join(ipc_separator(), time, $pid, $tid) . ".jsonl"); + $stream = Test2::Harness::Util::File::JSONL->new(name => $file); + $self->{+STATE}->transaction(w => sub { + my ($state) = @_; + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + push @$files => $file; + }); + } + + $stream->write($_) for @_; + }; +} + +sub _generate_reader { + my $self = shift; + my ($type, @path) = @_; + + my $workdir = $self->state->workdir; + my $path = File::Spec->catdir($workdir, $self->{+RUN_ID}, @path); + make_path($path) unless -d $path; + + my ($tid, $pid, %streams) = (0, 0); + my $reader_sub = sub { + if ($tid != get_tid() || $pid != $$) { + $tid = get_tid(); + $pid = $$; + + # Clear stream cache on new proc/thread + %streams = (); + } + + my @events; + + my $files = $self->_get_file_list($type, $self->{+RUN_ID}, @path); + for my $file (@$files) { + my $stream = $streams{$file} //= Test2::Harness::Util::File::JSONL->new(name => $file); + push @events => $stream->poll(); + } + + return @events; + }; + + return $reader_sub; +} + +sub _get_file_list { + my $self = shift; + my @path = @_; + my $last = pop @path; + + my $data = $self->{+STATE}->data->ipc_model; + $data = $data->{$_} //= {} for @path; + $data = $data->{$last} //= []; + return $data; +} + +sub finish { + my $self = shift; + $self->render_event(undef); +} + +1; diff --git a/liby/Test2/Harness/IPC/Process.pm b/liby/Test2/Harness/IPC/Process.pm new file mode 100644 index 000000000..d15e472be --- /dev/null +++ b/liby/Test2/Harness/IPC/Process.pm @@ -0,0 +1,134 @@ +package Test2::Harness::IPC::Process; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <exit <exit_time + <pid + +category +}; + +sub category { $_[0]->{+CATEGORY} //= 'default' } + +sub set_pid { + my $self = shift; + my ($pid) = @_; + + croak "pid has already been set" if defined $self->{+PID}; + + $self->{+PID} = $pid; +} + +sub set_exit { + my $self = shift; + my ($ipc, $exit, $time) = @_; + + croak "exit has already been set" if defined $self->{+EXIT}; + + $self->{+EXIT} = $exit; + $self->{+EXIT_TIME} = $time; +} + +sub spawn_params { + my $self = shift; + my $class = ref($self) || $self; + + croak "Process class '$class' does not implement 'spawn_params()'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::Process - Base class for processes controlled by +Test2::Harness::IPC. + +=head1 DESCRIPTION + +All processes controlled by L<Test2::Harness::IPC> should subclass this one. + +=head1 ATTRIBUTES + +=over 4 + +=item $int = $proc->exit + +Exit value, if set. Otherwise C<undef>. + +=item $stamp = $proc->exit_time + +Timestamp of the process exit, if set, otherwise C<undef>. + +=item $pid = $proc->pid + +Pid of the process, if it has been started. + +=item $cat = $proc->category + +Set at construction, C<'default'> if not provided. + +=back + +=head1 METHODS + +=over 4 + +=item $opt->set_pid($pid) + +Set the process id. + +=item $opt->set_exit($ipc, $exit, $time) + +Set the process as complete. $exit should be the exit value. $time should be a +timestamp. $ipc is an instance of L<Test2::Harness::IPC>. + +=item $hashref = $opt->spawn_params() + +Used when spawning the process, args go to C<run_cmd()> from +L<Test2::Harness::Util::IPC>. + +The base class throws an exception if this method is called. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/IPC/SharedState.pm b/liby/Test2/Harness/IPC/SharedState.pm new file mode 100644 index 000000000..769e302a2 --- /dev/null +++ b/liby/Test2/Harness/IPC/SharedState.pm @@ -0,0 +1,330 @@ +package Test2::Harness::IPC::SharedState; +use strict; +use warnings; + +our $VERSION = '1.000146'; + +use Test2::Harness::Util::File::JSON; +use Scalar::Util qw/weaken blessed/; +use Time::HiRes qw/time stat/; +use Carp qw/croak confess/; +use Fcntl qw/:flock/; +use Errno qw/EINTR EAGAIN ESRCH/; + +use Test2::Harness::Util::HashBase qw{ + <state_file <state_fh <state_umask + + <access_id <access_pid <access_meta + <timeout + + +transaction + + <registered <unregistered +}; + +use constant LOCAL => 'local'; +use constant ACCESS => 'access'; + +sub state_class {} + +sub init { + my $self = shift; + + croak "'state_file' is a required attribute" unless $self->{+STATE_FILE}; + + $self->{+TIMEOUT} //= 300; # Timeout runs if they do not update at least every 5 min + $self->{+STATE_UMASK} //= 0007; +} + +sub state { shift->transaction('r') } +sub data { shift->transaction('r') } + +sub init_state { + my $self = shift; + return {timeout => $self->{+TIMEOUT}}; +} + +sub transaction { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $mode //= 'r'; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + croak "mode must be 'w', 'rw', 'r', or 'ro', got '$mode'" unless $write || $read; + + if ($write) { + confess "Write mode requires a 'access_id'" unless $self->access_id; + my $pid = $self->access_pid or confess "Write mode requires a 'access_pid'"; + confess "Access PID mismatch ($pid vs $$)" unless $$ == $pid; + } + + my ($lock, $state, $local, $new); + if ($state = $self->{+TRANSACTION}) { + $new = 0; + $local = $state->{+LOCAL}; + + confess "Attempted a 'write' transaction inside of a read-only transaction" + if $write && !$local->{write}; + } + else { + $new = 1; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $lockf = "$self->{+STATE_FILE}.LOCK"; + + open($lock, '>>', $lockf) or die "Could not open lock file '$lockf': $!"; + while (1) { + last if flock($lock, $write ? LOCK_EX : LOCK_SH); + next if $! == EINTR || $! == EAGAIN; + warn "Could not get lock: $!"; + } + + $state = $self->_read_state(); + 1; + }; + my $err = $@; + umask($oldmask); + die $err unless $ok; + + $local = $state->{+LOCAL} = { + lock => $lock, + mode => $mode, + write => $write, + stack => [{cb => $cb, args => \@args}], + }; + + weaken($state->{+LOCAL}->{lock}); + } + + local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => \@args}]) + if $self->{+TRANSACTION}; + + local $self->{+TRANSACTION} = $state; + + if ($new) { + if ($write) { + if ($self->registered) { + $self->_verify_registration($state); + } + else { + $self->_update_registration($state); + } + } + $self->_clear_old_registrations($state); + } + + my $out; + my $ok = eval { $out = $cb ? $self->$cb($state, @args) : $state; 1 }; + my $err = $@; + + if ($ok && $write && $new) { + $self->_clear_old_registrations($state); + $self->_update_registration($state) unless $self->{+UNREGISTERED}; + $self->_write_state($state); + } + + if ($lock) { + flock($lock, LOCK_UN) or die "Could not release lock: $!"; + } + + die $err unless $ok; + + return $out; +} + +sub _read_state { + my $self = shift; + + return $self->init_state unless -e $self->{+STATE_FILE}; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + + my ($ok, $err, $state); + for (1 .. 5) { + $ok = eval { $state = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.2; + } + + warn "Corrupted state? Resetting state to initial. Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + $state ||= $self->init_state; + + $self->sync_from_state($state); + + my $class = $self->state_class or return $state; + return $state if blessed($state); + return bless($state, $class); +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->{+TIMEOUT} = $state->{timeout}; +} + +sub _write_state { + my $self = shift; + my ($state) = @_; + + my $state_copy = {%$state}; + + my $local = delete $state_copy->{+LOCAL}; + + confess "Attempted write with no lock" unless $local->{lock}; + confess "Attempted write with a read-only lock" unless $local->{write}; + + my $oldmask = umask($self->{+STATE_UMASK}); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); + $file->rewrite($state_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +sub update_registration { $_[0]->transaction(rw => '_update_registration') } +sub remove_registration { $_[0]->transaction(rw => '_update_registration', remove => 1) } + +sub _update_registration { + my $self = shift; + my ($state, %params) = @_; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id} //= { + %{$self->{+ACCESS_META} // {}}, + access_id => $access_id, + access_pid => $self->access_pid, + user => $ENV{USER}, + added => time, + }; + + # Update our last checkin time + $entry->{seen} = time; + + $self->{+REGISTERED} = $$; + + return $state unless $params{remove}; + + $self->{+UNREGISTERED} = 1; + $entry->{remove} = 1; + + return $state; +} + +sub _verify_registration { + my $self = shift; + my ($state) = @_; + + return unless $self->registered; + + my $access_id = $self->access_id; + my $entry = $state->{+ACCESS}->{$access_id}; + + # Do not allow for a new expiration. If the state has already expired us we will see it. + $entry->{seen} = time if $entry; + + return unless $self->{+UNREGISTERED} //= $self->_entry_expired($entry); + + confess "Shared state registration expired"; +} + +sub _entry_expired { + my $self = shift; + my ($entry) = @_; + + return 1 unless $entry; + return 1 if $entry->{remove}; + + if (my $pid = $entry->{+ACCESS_PID}) { + my $ret = kill(0, $pid); + my $err = $!; + return 1 if $ret == 0 && $! == ESRCH; + } + + my $seen = $entry->{seen} or return 1; + my $delta = time - $seen; + + return 1 if $self->{+TIMEOUT} && $delta > $self->{+TIMEOUT}; + + return 0; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $access = $state->{+ACCESS} //= {}; + + my (%removed); + for my $entry (values %$access) { + $entry->{remove} = 1 if $self->_entry_expired($entry); + next unless $entry->{remove}; + + my $access_id = $entry->{access_id}; + + $self->{+UNREGISTERED} = 1 if $access_id eq $self->access_id; + + delete $access->{$access_id}; + + $removed{$access_id}++; + } + + return [keys %removed]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::IPC::SharedState - IPC Shared State + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Log.pm b/liby/Test2/Harness/Log.pm new file mode 100644 index 000000000..385548c0e --- /dev/null +++ b/liby/Test2/Harness/Log.pm @@ -0,0 +1,289 @@ +package Test2::Harness::Log; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log - Documentation about the L<Test2::Harness> log file. + +=head1 DESCRIPTION + +L<Test2::Harness> aka L<App::Yath> produces a rich/complete log when asked to +do so. This module documents the log format. + +=head1 COMPRESSION + +Test2::Harness can output log files uncompressed, compressed in gzip, or +compressed in bzip2. + +=head1 FORMAT + +The log file is in jsonl format. Each line of the log can be indepentantly +parsed as json. Each line represents a single event Test2::Harness processed +during a run. These events will be in the original order Test2::Harness +processed them in (may not be chronological to when they were generated as +generation, collection, processing, and rendering are handled in different +processes. A complete log will be terminated by the string C<null>, which is +also valid json. If a log is missing this terminator it is considered an +incomplete log. + +=head2 EVENTS + +B<Please note:> Older versions of Test2::Harness produced less complete events, +this covers all current fields, if you are attempting to handle very old logs +some of these fields may be missing. + +Each event will have the following fields: + + { + "event_id" : "CD01CD30-D535-11EA-9B6A-D90F9664FE12", + "job_id" : 0, + "job_try" : null, + "run_id" : "CCF98E54-D535-11EA-915A-D70F9664FE12", + "stamp" : 1596423763.76517, + + "facet_data" : { + "harness" : { + "event_id" : "CD01CD30-D535-11EA-9B6A-D90F9664FE12", + "job_id" : 0, + "job_try" : null, + "run_id" : "CCF98E54-D535-11EA-915A-D70F9664FE12" + }, + + ... + } + } + +=over 4 + +=item event_id : "UUID_OR_STRING" + +Typically this will be a UUID, but when UUIDs cannot be generated it may have a +different unique identifier. This will always be a string. This may never be +NULL, if it is NULL then that is a bug and should be reported. + +=item job_id : "0_OR_UUID_OR_STRING" + +ID C<0> is special in that it represents the test harness itself, and not an +actual test being run. Normally the job_id will be a UUID, but may be another +unique string if UUID generation is disabled or not available. + +=item job_try : INTEGER_OR_NULL + +For C<< job_id => 0 >> this will be C<NULL> for any other job this will be an +intgeger of 0 or greater. This is 0 for the first time a test job is run, if a +job is re-run due to failure (or any other reason) this will be incremented to +tell you what run it is. When a job is re-run it keeps the same job ID, you can +use this to distinguish events from each run of the job. + +=item run_id : "UUID_OR_STRING" + +This is the run_id of the entire yath test run. This should be the same for +every event in any given log. + +=item stamp : UNIX_TIME_STAMP + +Timestamp of the event. This is NORMALLY set when an event is generated, +however if an event does not have its own time stamp yath will give it a +timestamp upon collection. Events without timestamps happen if the test outputs +TAP instead of L<Test2::Event> objects, or if a tool misbehaves in some way. + +=item facet_data : HASH + +This contains all the the data of the event, such as if an assertion was made, +what file name and line number generated it, etc. + +In addition to the original facets of the event, Test2::Harness may inject the +following facets (or generate completely new events to convey these facets). + +=over 4 + +=item harness_final + +This will contain the final summary data from the end of the test run. + + { + # Was the test run a success, or were there failures? + pass => $BOOL, + + # What tests failed? + failed => [ + [ + $job_id, # Job id of the job that failed + $file, # Test filename + ], + ... + ], + + # What tests had to be retried, and did they eventually pass? + retried => [ + [ + $job_id, # Job id of the job that was retied + $tries, # Number of tries attempted + $file, # Test filename + $eventually_passed, # 'YES' if it eventually passed, 'NO' if no try ever passed. + ], + ... + ], + + # What tests setn a halt event (such as bail-out, or skip the rest) + halted => [ + [ + $job_id, # Job id of the test + $file, # Test filename + $halt, # Halt code + ], + ... + ], + + # What tests were never run (maybe because of a bail-out, or an internal error) + unseen => [ + [ + $job_id, # Job id of the test + $file, # Test filename + ], + ... + ], + } + +=item harness_watcher + +Internal use only, subject to change, do not rely on it. + +=item harness_job + +A hash representation of an L<Test2::Harness::Runner::Job> object. + +B<Note:> This is done via a transformation, several methods have their values +stored in this hash when the original object does not directly store them. + +=item harness_job_end + + { + file => $provided_path_to_test_file, + rel_file => $relative_path_to_test_file, + abs_file => $absolute_path_to_test_file, + + fail => $BOOL, + retry => $INTEGER, # Number of retries left + stamp => $UNIX_TIMESTAMP, # Timestamp of when the test completed + + # May not be present + skip => $STRING, # Reason test was skipped (if it was skipped) + times => $TIMING_DATA, # See below + } + +The C<times> field is populated by calling C<data_dump()> on an +L<Test2::Harness::Auditor::TimeTracker> Object. + +=item harness_job_exit + +This represents when the test job exited. + + { + exit => $WSTAT, + retry => $INTEGER + stamp => $UNIX_TIMESTAMP + } + +=item harness_job_fields + +Extra data attached to the harness job, usually from an +L<Test2::Harness::Plugin> via C<inject_run_data()>. + +=item harness_job_launch + +This facet is almost always in the same event as the C<harness_job_start> +facet. I<NOTE:> While writing these docs the author wonders if this facet is +unnecessary... + + { + stamp => $UNIX_TIMESTAMP, + rety => $INTEGER, + } + + +=item harness_job_queued + +This data is produced by the C<queue_item> method in +L<Test2::Harness::TestFile>. + +This contains the data about a test job conveyed by the queue. This usually +contains data that will later be used by L<Test2::Harness::Runner::Job>. It is +better to use the C<harness_job> facet, which contains the final data used to +run the job. + +The following 3 fields are the only ones likely to be useful to most people: + + { + file => $ORIGINAL_PATH_TO_FILE, + job_id => $UUID_OR_STRING, + stamp => $UNIX_TIMESTAMP, + } + +=item harness_job_start + +This facet is sent in an event as soon as a job starts. The data in this facet +is mainly intended to convey necessary information to a renderer so that it can +render the fact that a job started. + + { + file => $provided_path_to_test_file, + rel_file => $relative_path_to_test_file, + abs_file => $absolute_path_to_test_file, + + stamp => $UNIX_TIMESTAMP, # Timestamp of when the test completed + job_id => $UUID_OR_STRING, + + details => "Job UUID_OR_STRING started at $UNIX_TIMESTAMP", + } + +=item harness_run + +A hash representation of an L<Test2::Harness::Run> object. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Log/CoverageAggregator.pm b/liby/Test2/Harness/Log/CoverageAggregator.pm new file mode 100644 index 000000000..e3893e7eb --- /dev/null +++ b/liby/Test2/Harness/Log/CoverageAggregator.pm @@ -0,0 +1,405 @@ +package Test2::Harness::Log::CoverageAggregator; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Find qw/find/; +use Test2::Harness::Util::HashBase qw/<touched <job_map +can_touch +can_start_test +can_stop_test +can_record_coverage <file +io <encode/; + +sub init { + my $self = shift; + $self->{+TOUCHED} //= {}; + $self->{+JOB_MAP} //= {}; + + $self->{+CAN_TOUCH} = !!$self->can('touch'); + $self->{+CAN_START_TEST} = !!$self->can('start_test'); + $self->{+CAN_STOP_TEST} = !!$self->can('stop_test'); + $self->{+CAN_RECORD_COVERAGE} = !!$self->can('record_coverage'); + + if (my $file = $self->{+FILE}) { + open(my $fh, '>', $file) or die "Could not open file '$file' for writing: $!"; + $self->{+IO} = $fh; + } +} + +sub flush { } +sub finalize { $_[0]->write } +sub record_metrics { } + +sub write { + my $self = shift; + + my $list = $self->flush() or return; + my $io = $self->{+IO} or return $list; + + my $encode = $self->{+ENCODE}; + for my $item (@$list) { + my $encoded = $encode ? $encode->($item) : $item; + print $io $encoded; + } + + return $list; +} + +sub process_event { + my $self = shift; + my ($e) = @_; + + return unless $e; + return unless keys %$e; + + my $job_map = $self->{+JOB_MAP} //= {}; + my $job_id = $e->{job_id} // 0; + + my $test = $job_map->{$job_id}; + + if (my $start = $e->{facet_data}->{harness_job_start}) { + $test //= $start->{rel_file}; + + $self->start_test($test, $e) if $self->{+CAN_START_TEST}; + } + + if (my $end = $e->{facet_data}->{harness_job_end}) { + $test //= $end->{rel_file}; + + $self->stop_test($test, $e) if $self->{+CAN_STOP_TEST}; + } + + $job_map->{$job_id} //= $test if $test; + + if (my $c = $e->{facet_data}->{coverage}) { + die "Got coverage data before test start! (Weird event order?)" unless $test; + $self->_touch_coverage($test, $c, $e); + $self->record_coverage($test, $c, $e) if $self->{+CAN_RECORD_COVERAGE}; + } + + return $self->write(); +} + +sub _touch_coverage { + my $self = shift; + my ($test, $data, $e) = @_; + + if (my $new = $data->{files}) { + for my $file (keys %$new) { + my $ndata = $new->{$file} // next; + for my $sub (keys %$ndata) { + $self->{+TOUCHED}->{$file}->{$sub}++; + + next unless $self->{+CAN_TOUCH}; + $self->touch(source => $file, sub => $sub, test => $test, manager_data => $ndata->{$sub}, event => $e); + } + } + } +} + +my %PERL_TYPES = ( + pl => 1, + pm => 1, + t => 1, + tx => 1, + t2 => 1, + pmc => 1, +); + +sub build_metrics { + my $self = shift; + my %params = @_; + + my $private = $params{exclude_private}; + + my $dirs = $params{dirs} // ['lib']; + my $types = $params{types} // ['pm', 'pl']; + my $touched = $self->{+TOUCHED} //= {}; + + my $metrics = { + files => {total => 0, tested => 0}, + subs => {total => 0, tested => 0}, + untested => {files => [], subs => {}}, + }; + + my $untested = $metrics->{untested}; + + my %type_check = map { m/\.?([^\.]+)$/g; (lc($1) => 1) } @$types; + + my $raw_untested = {}; + find( + { + no_chdir => 1, + wanted => sub { + my $type = lc($_); + $type =~ s/^.*\.([^\.]+)$/$1/; + return unless $type_check{$type}; + $metrics->{files}->{total}++; + + my $file = $File::Find::name; + my $cfile = $touched->{$file}; + + if ($cfile) { + $metrics->{files}->{tested}++ + } + else { + push @{$untested->{files}} => $file; + } + + for my $sub ($PERL_TYPES{$type} ? $self->scan_subs($file) : ('<>')) { + next if $sub =~ m/^_/ && $private; + + my $special_sub = $sub !~ m/^\w/; + + $metrics->{subs}->{total}++ unless $special_sub; + + if ($cfile && $cfile->{$sub}) { + $metrics->{subs}->{tested}++ unless $special_sub; + } + else { + $raw_untested->{$file}->{$sub} = 1; + } + } + }, + }, + @$dirs + ); + + for my $file (keys %$raw_untested) { + my @val = keys %{$raw_untested->{$file}}; + next unless @val; + + if (@val == 1 && $val[0] eq '<>') { + push @{$untested->{files}} => $file; + } + else { + $untested->{subs}->{$file} = [sort @val]; + } + } + + my %seen; + @{$untested->{files}} = sort grep { !$seen{$_}++ } @{$untested->{files}}; + + $self->record_metrics($metrics); + + return $metrics; +} + +sub scan_subs { + my $self = shift; + my ($file) = @_; + + my @subs; + + my $fh; + unless (open($fh, '<', $file)) { + warn "Could not open file '$file': $!"; + return; + } + + my $in_pod = 0; + while (my $line = <$fh>) { + $in_pod = 1 if $line =~ m/^=\w/; + + if ($in_pod) { + next unless $line =~ m/^=cut/i; + $in_pod = 0; + next; + } + + last if $line =~ m/^__(END|DATA)__$/; + + next unless $line =~ m/^\s*sub\s+(\w+)/; + push @subs => $1; + } + + return @subs; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator - Module for aggregating coverage data +from a stream of events. + +=head1 DESCRIPTION + +This module takes a stream of events and produces aggregated coverage data. + +=head1 SYNOPSIS + + use Test2::Harness::Log::CoverageAggregator; + + my $agg = Test2::Harness::Log::CoverageAggregator->new(); + + while (my $e = $log->next_event) { + $agg->process_event($e); + } + + # Get a structure like { source_file => { source_method => $touched_count, ... }, ...} + my $touched_source = $agg->touched; + + # Get a structure like + # { + # files => {total => 5, tested => 2}, + # subs => {total => 20, tested => 12}, + # untested => {files => \@file_list, subs => {file => \@sub_list, ...}}, + # } + my $metrics = $agg->metrics; + + +=head1 METHODS + +=head2 IMPLEMENTABLE IN SUBLCASSES + +If you implement these in a subclass they will be called for you at the proper +times, making subclassing much easier. In most cases you can avoid overriding +process_event(). + +=over 4 + +=item $agg->start_test($test, $event) + +This is called once per test when it starts. + +B<Note:> If a test is run more than once (re-run) it will start and stop again +for each re-run. The event is also provided as an argument so that you can +check for a try-id or similar in the event that re-runs matter to you. + +=item $agg->stop_test($test, $event) + +This is called once per test when it stops. + +B<Note:> If a test is run more than once (re-run) it will start and stop again +for each re-run. The event is also provided as an argument so that you can +check for a try-id or similar in the event that re-runs matter to you. + +=item $agg->record_coverage($test, $coverage_data, $event) + +This is called once per coverage event (there can be several in a test, +specially if it forks or uses threads). + +In most cases you probably want to leave this unimplemented and implement the +C<touch()> method instead of iterating over the coverage structure yourself. + +=item $agg->touch(source => $file, sub => $sub, test => $test, manager_data => $mdata, event => $event) + +Every touch applied to a source file (and sub) will trigger this method call. + +=over 4 + +=item source => $file + +The source file that was touched + +=item sub => $sub + +The source subroutine that was touched. B<Note:> This may be '<>' if the source +file was opened via C<open()> or '*' if code outside of a subroutine was +executed by the test. + +=item test => $test + +The test file that did the touching. + +=item manager_data => $mdata + +If the test file makes use of a source manager to attach extra data to +coverage, this is where that data will be. A good example would be test suites +that use tools similar to Test::Class or Test::Class::Moose where all tests are +run in methods and you want to track what test method does the touching. Please +note that this level of coverage tracking is not automatic. + +=item event => $event + +The full event being processed. + +=back + +=back + +=head2 PUBLIC API + +=over 4 + +=item $agg->process_event($event) + +Process the event, aggregating any coverage info it may contain. + +=item $touched = $add->touched() + +Returns the following structure, which tells you how many times a specific +source file's subroutines were called. There are also "special" subroutines +'<>' and '*' which mean "file was opened via open" and "code outside of a +subroutine". + + { + source_file => { + source_method => $touched_count, + ... + }, + ... + } + +=item $metrics = $agg->build_metrics() + +=item $metrics = $agg->build_metrics(exclude_private => $BOOL) + +Will build metrics, and include them in the output from C<< $agg->coverage() >> +next time it is called. + +The C<exclude_private> option, when set to true, will exclude any method that +beings with an underscore from the coverage metrics and untested sub list. + +Metrics: + + { + files => {total => 20, tested => 18}, + subs => {total => 80, tested => 70}, + + untested => { + files => \@file_list, + subs => { + file => \@sub_list, + ... + } + }, + } + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Log/CoverageAggregator/ByRun.pm b/liby/Test2/Harness/Log/CoverageAggregator/ByRun.pm new file mode 100644 index 000000000..1b8f0407a --- /dev/null +++ b/liby/Test2/Harness/Log/CoverageAggregator/ByRun.pm @@ -0,0 +1,220 @@ +package Test2::Harness::Log::CoverageAggregator::ByRun; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use parent 'Test2::Harness::Log::CoverageAggregator'; +use Test2::Harness::Util::HashBase qw/<coverage <finalized/; + +sub init_coverage { + my $self = shift; + return $self->{+COVERAGE} //= {aggregator => blessed($self)}; +} + +sub record_coverage { + my $self = shift; + my ($test, $data) = @_; + + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + my $files = $coverage->{files} //= {}; + my $alltestmeta = $coverage->{testmeta} //= {}; + my $testmeta = $alltestmeta->{$test} //= {type => 'flat'}; + + if (my $type = $data->{test_type}) { + $testmeta->{type} = $type; + } + + if (my $manager = $data->{from_manager}) { + $testmeta->{manager} = $manager; + } +} + +sub touch { + my $self = shift; + my %params = @_; + + my $file = $params{source}; + my $sub = $params{sub}; + my $test = $params{test}; + my $mdata = $params{manager_data}; + + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + my $files = $coverage->{files} //= {}; + + my $set = $files->{$file}->{$sub}->{$test} //= []; + + return unless $mdata; + my $type = ref $mdata; + + if ($type eq 'ARRAY') { + my %seen; + @$set = grep { !$seen{$_}++ } @$set, @$mdata; + } + else { + push @$set => $mdata; + } +} + +sub record_metrics { + my $self = shift; + my ($metrics) = @_; + my $coverage = $self->{+COVERAGE} // $self->init_coverage; + $coverage->{untested} = $metrics->{untested}; + $coverage->{metrics} = {files => $metrics->{files}, subs => $metrics->{subs}}; +} + +sub flush { + my $self = shift; + return unless $self->{+FINALIZED}; + return [ $self->{+COVERAGE} // $self->init_coverage ]; +} + +sub finalize { + my $self = shift; + $self->{+FINALIZED} = 1; + $self->SUPER::finalize(); +} + +sub get_coverage_tests { + my $class = shift; + my ($settings, $changes, $coverage_data) = @_; + + my $filemap = $coverage_data->{files} // {}; + my $testmeta = $coverage_data->{testmeta} // {}; + + my ($changes_exclude_loads, $changes_exclude_opens); + if ($settings->check_prefix('finder')) { + my $finder = $settings->finder; + $changes_exclude_loads = $finder->changes_exclude_loads; + $changes_exclude_opens = $finder->changes_exclude_opens; + } + + my %tests; + for my $file (keys %$changes) { + my $parts_map = $changes->{$file}; + my $parts_list = [keys %$parts_map]; + + my $use_parts; + if (!@$parts_list || $parts_map->{'*'}) { + $use_parts = [keys %{$filemap->{$file}}]; + } + else { + $use_parts = $parts_list; + } + + my %seen; + for my $part (@$use_parts) { + next if $seen{$part}++; + my $ctests = $filemap->{$file}->{$part} or next; + for my $test (keys %$ctests) { + push @{$tests{$test}->{subs}} => @{$ctests->{$test}}; + } + } + + unless ($changes_exclude_opens) { + if (my $ltests = $filemap->{$file}->{'*'}) { + for my $test (keys %$ltests) { + push @{$tests{$test}->{loads}} => @{$ltests->{$test}}; + } + } + } + + unless ($changes_exclude_loads) { + if (my $otests = $filemap->{$file}->{'<>'}) { + for my $test (keys %$otests) { + push @{$tests{$test}->{opens}} => @{$otests->{$test}}; + } + } + } + } + + my @out; + for my $test (sort keys %tests) { + my $meta = $testmeta->{$test} // {type => 'flat'}; + my $type = $meta->{type}; + my $manager = $meta->{manager}; + + # In these cases we have no choice but to run the entire file + if ($type eq 'flat' || !$manager) { + push @out => $test; + next; + } + + die "Invalid test type: $type" unless $type eq 'split'; + + my $froms = $tests{$test} // []; + my $ok = eval { + require(mod2file($manager)); + my $specs = $manager->test_parameters($test, $froms, $changes, $coverage_data, $settings); + + $specs = { run => $specs } unless ref $specs; + + push @out => [$test, $specs] + unless defined $specs->{run} && !$specs->{run}; # Intentional skip + + 1; + }; + my $err = $@; + + next if $ok; + + warn "Error processing coverage data for '$test' using manager '$manager'. Running entire test to be safe.\nError:\n====\n$@\n====\n"; + push @out => $test; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator::ByRun - Aggregate test data by run + +=head1 DESCRIPTION + + +=head1 SYNOPSIS + + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Log/CoverageAggregator/ByTest.pm b/liby/Test2/Harness/Log/CoverageAggregator/ByTest.pm new file mode 100644 index 000000000..ae5b90a86 --- /dev/null +++ b/liby/Test2/Harness/Log/CoverageAggregator/ByTest.pm @@ -0,0 +1,218 @@ +package Test2::Harness::Log::CoverageAggregator::ByTest; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Scalar::Util qw/blessed/; +use Test2::Harness::Util qw/mod2file/; + +use parent 'Test2::Harness::Log::CoverageAggregator'; +use Test2::Harness::Util::HashBase qw/<in_progress <completed/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + $self->{+IN_PROGRESS} //= {}; + $self->{+COMPLETED} //= []; +} + +sub start_test { + my $self = shift; + my ($test) = @_; + + $self->{+IN_PROGRESS}->{$test} //= {test => $test, files => {}, aggregator => blessed($self)}; +} + +sub stop_test { + my $self = shift; + my ($test) = @_; + + push @{$self->{+COMPLETED}} => delete $self->{+IN_PROGRESS}->{$test}; +} + +sub record_coverage { + my $self = shift; + my ($test, $data) = @_; + + if (my $manager = $data->{from_manager}) { + $self->{+IN_PROGRESS}->{$test}->{manager} = $manager; + } +} + +sub touch { + my $self = shift; + my %params = @_; + + my $file = $params{source}; + my $sub = $params{sub}; + my $test = $params{test}; + my $mdata = $params{manager_data}; + + my $set = $self->{+IN_PROGRESS}->{$test}->{files}->{$file}->{$sub} //= []; + + return unless $mdata; + my $type = ref $mdata; + + if ($type eq 'ARRAY') { + if (@$set) { + my %seen; + @$set = grep { !$seen{$_}++ } @$set, @$mdata; + } + else { + push @$set => @$mdata; + } + } + else { + push @$set => $mdata; + } +} + +sub flush { + my $self = shift; + + my $data = $self->{+COMPLETED} //= []; + + return unless @$data; + + $self->{+COMPLETED} = []; + + return $data; +} + +sub finalize { + my $self = shift; + + my $ip = $self->{+IN_PROGRESS}; + my $cm = $self->{+COMPLETED} //= []; + + push @{$cm} => {$_ => delete $ip->{$_}} for keys %$ip; + + $self->SUPER::finalize(); +} + +sub get_coverage_tests { + my $class = shift; + my ($settings, $changes, $coverage_data) = @_; + + my $test = $coverage_data->{test} // return; + my $filemap = $coverage_data->{files} // {}; + my $manager = $coverage_data->{manager} // undef; + + my ($changes_exclude_loads, $changes_exclude_opens); + if ($settings->check_prefix('finder')) { + my $finder = $settings->finder; + $changes_exclude_loads = $finder->changes_exclude_loads; + $changes_exclude_opens = $finder->changes_exclude_opens; + } + + my %froms; + for my $file (keys %$changes) { + my $parts_map = $changes->{$file}; + my $parts_list = [keys %$parts_map]; + + my $use_parts; + if (!@$parts_list || $parts_map->{'*'}) { + $use_parts = [keys %{$filemap->{$file}}]; + } + else { + $use_parts = $parts_list; + } + + my %seen; + for my $part (@$use_parts) { + next if $seen{$part}++; + my $cfroms = $filemap->{$file}->{$part} or next; + push @{$froms{subs}} => @{$cfroms}; + } + + unless ($changes_exclude_loads) { + if (my $lfroms = $filemap->{$file}->{'*'}) { + push @{$froms{loads}} => @{$lfroms}; + } + } + + unless ($changes_exclude_opens) { + if (my $ofroms = $filemap->{$file}->{'<>'}) { + push @{$froms{opens}} => @{$ofroms}; + } + } + } + + # Nothing to do for this test + return unless keys %froms; + + # In these cases we have no choice but to run the entire file + return ($test) unless $manager; + + my @out; + my $ok = eval { + require(mod2file($manager)); + my $specs = $manager->test_parameters($test, \%froms, $changes, $coverage_data, $settings); + + $specs = { run => $specs } unless ref $specs; + + push @out => [$test, $specs] + unless defined $specs->{run} && !$specs->{run}; # Intentional skip + + 1; + }; + my $err = $@; + + return @out if $ok; + + warn "Error processing coverage data for '$test' using manager '$manager'. Running entire test to be safe.\nError:\n====\n$@\n====\n"; + return ($test); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Log::CoverageAggregator::ByTest - Aggregate coverage by test + +=head1 DESCRIPTION + + +=head1 SYNOPSIS + + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Plugin.pm b/liby/Test2/Harness/Plugin.pm new file mode 100644 index 000000000..b27cfb2b7 --- /dev/null +++ b/liby/Test2/Harness/Plugin.pm @@ -0,0 +1,349 @@ +package Test2::Harness::Plugin; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +# Document, but do not implement +#sub changed_files {} +#sub changed_diff {} + +sub munge_search {} + +sub claim_file {} + +sub munge_files {} + +sub inject_run_data {} + +sub setup {} + +sub teardown {} + +sub TO_JSON { ref($_[0]) || "$_[0]" } + +sub redirect_io { + my $this = shift; + my ($settings, $name) = @_; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "This cannot be used without a workspace $at" unless $settings->check_prefix('workspace'); + + require File::Spec; + require Test2::Harness::Util::IPC; + + my $dir = $settings->workspace->workdir; + my $aux = File::Spec->catdir($dir, 'aux_logs'); + mkdir($aux) unless -d $aux; + + Test2::Harness::Util::IPC::swap_io(\*STDOUT, File::Spec->catfile($aux, "${name}-STDOUT.log")); + Test2::Harness::Util::IPC::swap_io(\*STDERR, File::Spec->catfile($aux, "${name}-STDERR.log")); + + return; +} + +sub shellcall { + my $this = shift; + my ($settings, $name, @cmd) = @_; + + require POSIX; + + my @caller = caller(); + my $at = "at $caller[1] line $caller[2].\n"; + die "Invalid settings ($settings) $at" unless $settings && ref($settings) eq 'Test2::Harness::Settings'; + die "No name provided $at" unless $name; + die "No command provided $at" unless @cmd && length($cmd[0]); + + my $pid = fork // die "Could not fork: $!"; + if ($pid) { + waitpid($pid, 0); + return $?; + } + else { + local $@; + + eval { + if ($settings->check_prefix('workspace')) { + $this->redirect_io($settings, $name); + } + exec(@cmd) if @cmd > 1; + exec($cmd[0]); + }; + + chomp(my $err = $@ // "unknown error"); + + warn "Could not run command ($@) $at"; + POSIX::_exit(1); + } +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Plugin - Base class for Test2::Harness plugins. + +=head1 DESCRIPTION + +This class holds the methods specific to L<Test2::Harness> which +is the backend. Most of the time you actually want to subclass +L<App::Yath::Plugin> which subclasses this class, and holds additional methods +that apply to yath (the UI layer). + +=head1 SYNOPSIS + +You probably want to subclass L<App::Yath::Plugin> instead. This class here +mainly exists to separate concerns, but is not something you should use +directly. + + package Test2::Harness::Plugin::MyPlugin; + + use parent 'Test2::Harness::Plugin'; + + # ... Define methods + + 1; + +=head1 METHODS + +=over 4 + +=item $plugin->munge_search($input, $default_search, $settings) + +C<$input> is an arrayref of files and/or directories provided at the command +line. + +C<$default_search> is an arrayref with the default files/directories pulled in +when nothing is specified at the command ine. + +C<$settings> is an instance of L<Test2::Harness::Settings> + +=item $undef_or_inst = $plugin->claim_file($path, $settings) + +This is a chance for a plugin to claim a test file early, before Test2::Harness +takes care of it. If your plugin does not want to claim the file just return +undef. To claim the file return an instance of L<Test2::Harness::TestFile> +created with C<$path>. + +=item $plugin->munge_files(\@tests, $settings) + +This is an opportunity for your plugin to modify the data for any test file +that will be run. The first argument is an arrayref of +L<Test2::Harness::TestFile> objects. + +=item $hashref = $plugin->duration_data($settings, $test_names) + +If defined, this can return a hashref of duration data. This should return +undef if no duration data is provided. The first plugin listed that provides +duration data wins, no other plugins will be checked once duration data is +obtained. + +Example duration data: + + { + 't/foo.t' => 'medium', + 't/bar.t' => 'short', + 't/baz.t' => 'long', + } + +=item $hashref_or_arrayref = $plugin->coverage_data(\@changed) + +=item $hashref_or_arrayref = $plugin->coverage_data() + +If defined, this can return a hashref of all coverage data, or an arrayref of +tests that cover the tests listed in @changed. This should return undef if no +coverage data is available. The first plugin to provide coverage data wins, no +other plugins will be checked once coverage data has been obtained. + +Examples: + + [ + 'foo.t', + 'bar.t', + 'baz.t', + ] + + { + 'lib/Foo.pm' => [ + 't/foo.t', + 't/integration.t', + ], + 'lib/Bar.pm' => [ + 't/bar.t', + 't/integration.t', + ], + } + +=item $plugin->post_process_coverage_tests($settings, \@tests) + +This is an opportunity for a plugin to do post-processing on the list of +coverage tests to run. This is mainly useful to remove duplicates if multiple +plugins add coverage data, or merging entries where applicable. This will be +called after all plugins have generated their coverage test list. + +Plugins may implement this without implementing coverage_data(), making this +useful if you want to use a pre-existing coverage module and want to do +post-processing on what it provides. + +=item $plugin->inject_run_data(meta => $meta, fields => $fields, run => $run) + +This is a callback that lets your plugin add meta-data or custom fields to the +run event. The meta-data and fields are available in the event log, and are +particularily useful to L<App::Yath::UI>. + + sub inject_run_data { + my $class = shift; + my %params = @_; + + my $meta = $params{meta}; + my $fields = $params{fields}; + + # Meta-data is a hash, each plugin should define its own key, and put + # data under that key + $meta->{MyPlugin}->{stuff} = "Stuff!"; + + # Fields is an array of fields that a UI might want to display when showing the run. + push @$fields => {name => 'MyPlugin', details => "Human Friendly Stuff", raw => "Less human friendly stuff", data => $all_the_stuff}; + + return; + } + +=item $plugin->setup($settings) + +This is a callback that lets you run setup logic when the runner starts. Note +that in a persistent runner this is run once on startup, it is not run for each +C<run> command against the persistent runner. + +=item $plugin->teardown($settings) + +This is a callback that lets you run teardown logic when the runner stops. Note +that in a persistent runner this is run once on termination, it is not run for +each C<run> command against the persistent runner. + +=item @files = $plugin->changed_files($settings) + +Get a list of files that have changed. Plugins are free to define what +"changed" means. This may be used by the finder to determine what tests to run +based on coverage data collected in previous runs. + +Note that data from all changed_files() calls from all plugins will be merged. + +=item ($type, $value) = $plugin->changed_diff($settings) + +Generate a diff that can be used to calculate changed files/subs for which to +run tests. Unlike changed_files(), only 1 diff will be used, first plugin +listed that returns one wins. This is not run at all if a diff is provided via +--changed-diff. + +Diffs must be in the same format as this git command: + + git diff -U1000000 -W --minimal BASE_BRANCH_OR_COMMIT + +Some other diff formats may work by chance, but they are not dirfectly +supported. In the future other diff formats may be directly supported, but not +yet. + +The following return sets are allowed: + +=over 4 + +=item file => string + +Path to a diff file + +=item diff => string + +In memory diff as a single string + +=item lines => \@lines + +Diff where each line is a seperate string in an arrayref. + +=item line_sub => sub { ... } + +Sub that returns one line per call and undef when there are no more lines + +=item handle => $FH + +A filehandle to the diff + +=back + +=item $exit = $plugin->shellcall($settings, $name, $cmd) + +=item $exit = $plugin->shellcall($settings, $name, @cmd) + +This is essentially the same as C<system()> except that STDERR and STDOUT are +redirected to files that the yath collector will pick up so that any output +from the command will be seen as events and will be part of the yath log. If no +workspace is available this will not redirect IO and it will be identical to +calling C<system()>. + +This is particularily useful in C<setup()> and C<teardown()> when running +external commands, specially any that daemonize and continue to produce output +after the setup/teardown method has completed. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->redirect_io($settings, $name) + +B<WARNING:> This must NEVER be called in a primary yath process. Only use this +in forked processes that you control. If this is used in a main process it +could hide ALL output. + +This will redirect STDERR and STDOUT to files that will be picked up by the +yath collector so that any output appears as proper yath events and will be +included in the yath log. + +$name is required because it will be used for filenames, and will be used as +the output tag (best to limit it to 8 characters). + +=item $plugin->TO_JSON + +This is here as a bare minimum serialization method. It returns the plugin +class name. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Renderer.pm b/liby/Test2/Harness/Renderer.pm new file mode 100644 index 000000000..4442d0e7f --- /dev/null +++ b/liby/Test2/Harness/Renderer.pm @@ -0,0 +1,154 @@ +package Test2::Harness::Renderer; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw/-settings -verbose -progress -color -command_class/; + +sub render_event { croak "$_[0] forgot to override 'render_event()'" } + +sub step {} + +sub finish { } + +sub signal { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer - Base class for Test2::Harness event renderers. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be changed. + +=over 4 + +=item $settings = $renderer->settings + +Get the L<Test2::Harness::Settings> reference. + +=item $int = $renderer->verbose + +Get the verbosity level. + +=item $bool = $renderer->progress + +True if progress indicators should be shown. + +=item $bool = $renderer->color + +True if color should be used. + +=back + +=head1 METHODS + +=over 4 + +=item $renderer->render_event($event) + +Called for every event. Return is ignored. + +=item $renderer->finish(%ARGS) + +Called once after testing is done. + +C<%ARGS>: + +=item $renderer->signal($signal) + +Called when the rendering process receives a signal. This is your chance to do +any cleanup or report the signal. This is not an event, you can ignore it. Do +not exit or throw any exceptions here please. + +=over 4 + +=item settings => $settings + +Get the L<Test2::Harness::Settings> reference. + +=item pass => $bool + +True if tests passed. + +=item tests_seen => $int + +Number of test files seen. + +=item asserts_seen => $int + +Number of assertions made. + +=item final_data => $final_data + +The final_data looks like this, note that some data may not be present if it is +not applicable. The data structure can be as simple as +C<< { pass => $bool } >>. + + { + pass => $pass, # boolean, did the test run pass or fail? + + failed => [ # Jobs that failed, and did not pass on a retry + [$job_id1, $file1], # Failing job 1 + [$job_id2, $file2], # Failing job 2 + ... + ], + retried => [ # Jobs that failed and were retried + [$job_id1, $times_run1, $file1, $passed_eventually1], # Passed_eventually is a boolean + [$job_id2, $times_run2, $file2, $passed_eventually2], + ... + ], + hatled => [ # Jobs that caused the entire test suite to halt + [$job_id1, $file1, $halt_reason1], # halt_reason is a human readible string + [$job_id2, $file2, $halt_reason2], + ], + } + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Renderer/Formatter.pm b/liby/Test2/Harness/Renderer/Formatter.pm new file mode 100644 index 000000000..45f04f0ff --- /dev/null +++ b/liby/Test2/Harness/Renderer/Formatter.pm @@ -0,0 +1,215 @@ +package Test2::Harness::Renderer::Formatter; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Storable qw/dclone/; + +use Test2::Harness::Util qw/fqmod mod2file/; +use Test2::Harness::Util::JSON qw/encode_pretty_json/; + +BEGIN { require Test2::Harness::Renderer; our @ISA = ('Test2::Harness::Renderer') } +use Test2::Harness::Util::HashBase qw{ + -io -io_err + -formatter + -show_run_info + -show_job_info + -show_job_launch + -show_job_end + -do_step + -interactive +}; + +sub init { + my $self = shift; + + my $settings = $self->{+SETTINGS}; + + my $formatter = $self->{+FORMATTER} //= 'Test2'; + my $f_class = fqmod('Test2::Formatter', $formatter); + my $f_file = mod2file($f_class); + require $f_file; + + my $io = $self->{+IO} || $self->{output} || \*STDOUT; + unless (ref $io) { + open(my $fh, '>', $io) or die "Could not open file '$io' for writing: $!"; + $self->{+IO} = $fh; + } + + my $io_err = $self->{+IO_ERR} || $self->{output} || \*STDERR; + unless (ref $io_err) { + open(my $fh, '>', $io_err) or die "Could not open file '$io_err' for writing: $!"; + $self->{+IO_ERR} = $fh; + } + + $self->{+INTERACTIVE} = 1 if $settings->debug->interactive; + $self->{+INTERACTIVE} //= 1 if $ENV{YATH_INTERACTIVE}; + + $self->{+FORMATTER} = $f_class->new( + io => $self->{+IO}, + progress => $self->{+PROGRESS}, + handles => [$self->{+IO}, $self->{+IO_ERR}, $self->{+IO}], + verbose => $settings->display->verbose, + color => $settings->display->color, + no_wrap => $settings->display->no_wrap, + interactive => $self->{+INTERACTIVE}, + is_persistent => $self->{+COMMAND_CLASS}->group eq 'persist' ? 1 : 0, + ); + + $self->{+DO_STEP} = $self->{+FORMATTER}->can('step') ? 1 : 0; + + $self->{+SHOW_JOB_END} = 1 unless defined $self->{+SHOW_JOB_END}; +} + +sub step { + my $self = shift; + return unless $self->{+DO_STEP}; + $self->{+FORMATTER}->step; +} + +sub render_event { + my $self = shift; + my ($event) = @_; + + # We modify the event, which would be bad if there were multiple renderers, + # so we deep clone it. + $event = dclone($event); + + my $settings = $self->{+SETTINGS}; + + my $f = $event->{facet_data}; # Optimization + + $f->{harness} = {%$event}; + delete $f->{harness}->{facet_data}; + + if ($self->{+SHOW_RUN_INFO} && $f->{harness_run}) { + my $run = $f->{harness_run}; + + push @{$f->{info}} => { + tag => 'RUN INFO', + details => encode_pretty_json($run), + }; + } + + if ($f->{harness_job_launch}) { + my $job = $f->{harness_job}; + + $f->{harness}->{job_id} ||= $job->{job_id}; + + if ($self->{+SHOW_JOB_LAUNCH}) { + push @{$f->{info}} => { + tag => $f->{harness_job_launch}->{retry} ? 'RETRY' : 'LAUNCH', + debug => 0, + important => 1, + details => File::Spec->abs2rel($job->{file}), + }; + } + + if ($self->{+SHOW_JOB_INFO}) { + push @{$f->{info}} => { + tag => 'JOB INFO', + details => encode_pretty_json($job), + }; + } + } + + if ($f->{harness_job_end}) { + my $job = $f->{harness_job}; + my $skip = $f->{harness_job_end}->{skip}; + my $fail = $f->{harness_job_end}->{fail}; + my $file = $f->{harness_job_end}->{file}; + my $retry = $f->{harness_job_end}->{retry}; + + my $job_id = $f->{harness}->{job_id} ||= $job->{job_id}; + + # Make the times important if they were requested + if ($settings->display->show_times && $f->{info}) { + for my $info (@{$f->{info}}) { + next unless $info->{tag} eq 'TIME'; + $info->{important} = 1; + } + } + + if ($self->{+SHOW_JOB_END}) { + my $name = File::Spec->abs2rel($file); + $name .= " - $skip" if $skip; + + my $tag = 'PASSED'; + $tag = 'SKIPPED' if $skip; + $tag = 'FAILED' if $fail; + $tag = 'TO RETRY' if $retry; + + unshift @{$f->{info}} => { + tag => $tag, + debug => $fail, + important => 1, + details => $name, + }; + } + } + + my $num = $f->{assert} && $f->{assert}->{number} ? $f->{assert}->{number} : undef; + + $self->{+FORMATTER}->write($event, $num, $f); +} + +sub finish { + my $self = shift; + $self->{+FORMATTER}->finalize(); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Renderer::Formatter - Renderer that uses any Test2::Formatter +for rendering. + +=head1 DESCRIPTION + +This renderer simply acts as a communication layer between the harness and any +Test2 formatter that you wish to use to display results. Not all formatters +will produce useful output for harness events. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Run.pm b/liby/Test2/Harness/Run.pm new file mode 100644 index 000000000..06b13075d --- /dev/null +++ b/liby/Test2/Harness/Run.pm @@ -0,0 +1,182 @@ +package Test2::Harness::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <run_id + + <env_vars <author_testing <unsafe_inc + + <links + + <event_uuids + <use_stream + <mem_usage + <io_events + + <dbi_profiling + + <input <input_file <test_args + + <load <load_import + + <fields <meta + + <retry <retry_isolated +}; + +sub init { + my $self = shift; + + croak "run_id is required" + unless $self->{+RUN_ID}; +} + +sub run_dir { + my $self = shift; + my ($workdir) = @_; + return File::Spec->catfile($workdir, $self->{+RUN_ID}); +} + +sub TO_JSON { +{ %{$_[0]} } } + +sub queue_item { + my $self = shift; + my ($plugins) = @_; + + croak "a plugins arrayref is required" unless $plugins; + + my $out = {%$self}; + + my $meta = $out->{+META} //= {}; + my $fields = $out->{+FIELDS} //= []; + for my $p (@$plugins) { + $p->inject_run_data(meta => $meta, fields => $fields, run => $self); + } + + return $out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Run - Representation of a set of tests to run, and their +options. + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +These are set at construction time and cannot be modified. + +See L<App::Yath::Options::Run> for more documentation on these. + +=head2 FROM OPTIONS + +=over 4 + +=item $bool = $run->author_testing + +=item $hashref = $run->env_vars + +=item $bool = $run->event_uuids + +=item $arrayref = $run->fields + +=item $string = $run->input + +=item $path = $run->input_file + +=item $bool = $run->io_events + +=item $arrayref = $run->links + +=item $arrayref = $run->load + +=item $hashref = $run->load_import + +=item $bool = $run->mem_usage + +=item $int = $run->retry + +=item $bool = $run->retry_isolated + +=item $string = $run->run_id + +=item $arrayref = $run->test_args + +=item $bool = $run->unsafe_inc + +=item $bool = $run->use_stream + +=back + +=head2 OTHER + +=over 4 + +=item $hashref = $run->meta + +meta-data plugins may have attached. + +=back + +=head1 METHODS + +=over 4 + +=item $path = $run->run_dir($workdir) + +Returns the path C<"$workdir/$run_id">. + +=item $hashref = $run->queue_item(\@PLUGINS) + +Gets the queue item that represents this object. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner.pm b/liby/Test2/Harness/Runner.pm new file mode 100644 index 000000000..048837c6e --- /dev/null +++ b/liby/Test2/Harness/Runner.pm @@ -0,0 +1,692 @@ +package Test2::Harness::Runner; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec(); + +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use POSIX qw/:sys_wait_h/; +use Long::Jump qw/setjump longjump/; +use Time::HiRes qw/sleep time/; +use Scope::Guard; + +use Test2::Harness::Util qw/clean_path file2mod mod2file open_file parse_exit write_file_atomic process_includes chmod_tmp write_file/; +use Test2::Harness::Util::JSON(qw/encode_json/); + +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run(); +use Test2::Harness::Runner::Job(); +use Test2::Harness::Runner::Spawn(); +use Test2::Harness::Runner::State(); +use Test2::Harness::Runner::Preload(); +use Test2::Harness::Runner::Preloader(); +use Test2::Harness::Runner::Preloader::Stage(); +use Test2::Harness::Runner::DepTracer(); + +use parent 'Test2::Harness::IPC'; +use Test2::Harness::Util::HashBase( + # Fields from settings + qw{ + <job_count <slots_per_job + + <includes <tlib <lib <blib + <unsafe_inc + + <use_fork <preloads <preload_threshold <switches + <restrict_reload + + <cover + + <event_timeout <post_exit_timeout + + <resources + + <nytprof + + <reload + }, + # From Construction + qw{ + <dir <settings <fork_job_callback <fork_spawn_callback <respawn_runner_callback <monitor_preloads + <jobs_todo <dump_depmap <all_state + }, + # Other + qw { + +preloader + +state + + <stage + <signal + + +last_timeout_check + +dispatch_lock_file + +can_stage + <tmp_dir + + <rootpid + }, +); + +sub job_class { 'Test2::Harness::Runner::Job' } + +our $RUNNER_PID; +sub init { + my $self = shift; + + $self->{+ROOTPID} = $$; + $RUNNER_PID = $$; + + croak "'dir' is a required attribute" unless $self->{+DIR}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + my $dir = clean_path($self->{+DIR}); + + croak "'$dir' is not a valid directory" + unless -d $dir; + + $self->{+DIR} = $dir; + + $self->{+HANDLERS}->{HUP} = sub { + my $sig = shift; + print "$$ $0 ($self->{+STAGE}) Runner caught SIG$sig, reloading...\n"; + $self->{+SIGNAL} = $sig; + }; + + my $tmp_dir = File::Spec->catdir($self->{+DIR}, 'tmp'); + unless (-d $tmp_dir) { + mkdir($tmp_dir) or die "Could not create temp dir: $!"; + chmod_tmp($tmp_dir); + } + $self->{+TMP_DIR} = $tmp_dir; + + my $have_job_limiter = 0; + for my $res (@{$self->{+RESOURCES}}) { + require(mod2file($res)) unless ref($res); + $have_job_limiter++ if $res->job_limiter; + } + + unless ($have_job_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + unshift @{$self->{+RESOURCES}} => 'Test2::Harness::Runner::Resource::JobCount'; + } + + $self->SUPER::init(); +} + +sub preloader { + my $self = shift; + + $self->{+PRELOADER} //= Test2::Harness::Runner::Preloader->new( + dir => $self->{+DIR}, + preloads => $self->preloads, + monitor => $self->{+MONITOR_PRELOADS}, + restrict_reload => $self->{+RESTRICT_RELOAD}, + dump_depmap => $self->{+DUMP_DEPMAP}, + reload => $self->{+RELOAD}, + + below_threshold => ($self->{+PRELOAD_THRESHOLD} && $self->{+JOBS_TODO} && $self->{+PRELOAD_THRESHOLD} > $self->{+JOBS_TODO}) ? 1 : 0, + ); +} + +sub state { + my $self = shift; + + my $preloader = $self->preloader; + + my $settings = $self->settings; + $self->{+STATE} //= Test2::Harness::Runner::State->new( + workdir => $self->{+DIR}, + eager_stages => $preloader->eager_stages // {}, + preloader => $preloader, + resources => [map { $_->new(settings => $settings) } @{$self->{+RESOURCES}}], + settings => $settings, + ); +} + +sub check_timeouts { + my $self = shift; + + return unless $self->settings->runner->use_timeout; + + my $now = time; + + # Check only once per second, that is as granular as we get. Also the check is not cheep. + return if $self->{+LAST_TIMEOUT_CHECK} && $now < (1 + $self->{+LAST_TIMEOUT_CHECK}); + + for my $pid (keys %{$self->{+PROCS}}) { + my $job = $self->{+PROCS}->{$pid}; + next unless $job->isa('Test2::Harness::Runner::Job'); + next unless $job->use_timeout; + + my $et = $job->event_timeout // $self->{+EVENT_TIMEOUT}; + my $pet = $job->post_exit_timeout // $self->{+POST_EXIT_TIMEOUT}; + + next unless $et || $pet; + + my $changed = $job->output_changed(); + my $delta = $now - $changed; + + # Event timout if we are checking for one, and if the delta is larger than the timeout. + my $e_to = $et && $delta > $et; + + # Post-Exit timeout if we are checking for one, the process has exited (we are waiting) and the delta is larger than the timeout. + my $pe_to = $pet && $self->{+WAITING}->{$pid} && $delta > $pet; + + next unless $e_to || $pe_to; + + my $kill = -f $job->et_file || -f $job->pet_file; + + write_file_atomic($job->et_file, "$now $delta") if $e_to && !-f $job->et_file; + write_file_atomic($job->pet_file, "$now $delta") if $pe_to && !-f $job->pet_file; + + my $sigmap = $self->SIG_MAP; + my $sig = $kill ? $sigmap->{'KILL'} : $sigmap->{'TERM'}; + + $sig = "-$sig" if $self->USE_P_GROUPS; + + print STDERR "$$ $0 " . $job->file . " did not respond to SIGTERM, sending SIGKILL to $pid...\n" if $kill; + + # storing the jobid we had to stop + $self->{run_reached_timeout} //= {}; + $self->{run_reached_timeout}->{$job->task->{job_id}} = $pid; + + kill($sig, $pid); + } + + $self->{+LAST_TIMEOUT_CHECK} = time; +} + +sub stop { + my $self = shift; + + $self->check_for_fork; + + if (keys %{$self->{+PROCS}}) { + print "$$ $0 Sending all child processes the TERM signal...\n"; + # Send out the TERM signal + $self->killall($self->{+SIGNAL} // 'TERM'); + $self->wait(all => 1, timeout => 5); + } + + # Time to get serious + if (keys %{$self->{+PROCS}}) { + print STDERR "$$ $0 Some child processes are refusing to exit, sending KILL signal...\n"; + print("$$ $0 == $_ " . waitpid($_, WNOHANG) . "\n") for keys %{$self->{+PROCS}}; + $self->killall('KILL'); + } + + $self->SUPER::stop(); +} + +sub dispatch_lock_file { + my $self = shift; + return $self->{+DISPATCH_LOCK_FILE} //= File::Spec->catfile($self->{+DIR}, 'dispatch.lock'); +} + +sub handle_sig { + my $self = shift; + my ($sig) = @_; + + return if $self->{+SIGNAL}; + + return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; + + $self->{+SIGNAL} = $sig; + die "Runner caught SIG$sig. Attempting to shut down cleanly...\n"; +} + +sub all_libs { + my $self = shift; + + my @out; + + push @out => @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + push @out => 't/lib' if $self->{+TLIB}; + push @out => 'lib' if $self->{+LIB}; + + if ($self->{+BLIB}) { + push @out => 'blib/lib'; + push @out => 'blib/arch'; + } + + return @out; +} + +sub process { + my $self = shift; + + @INC = process_includes( + list => [@{$self->settings->harness->dev_libs}, $self->all_libs], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + ); + + my $pidfile = File::Spec->catfile($self->{+DIR}, 'PID'); + write_file_atomic($pidfile, "$$"); + + $self->start(); + + my $ok = eval { $self->run_tests(); 1 }; + my $err = $@; + $self->{+CAN_STAGE} = 0; + + warn $err unless $ok; + + $self->stop(); + + return $self->{+SIGNAL} ? 128 + $self->SIG_MAP->{$self->{+SIGNAL}} : $ok ? 0 : 1; +} + +sub spawn_scheduler { + my $self = shift; + + return unless $self->{+ROOTPID} == $$; + + my $pid = fork // die "Could not fork: $!"; + return $self->watch_pid($pid) if $pid; + + my $guard = Scope::Guard->new(sub { + print STDERR "\n\nEscaped Scope!!!!\n\n"; + print STDERR $@; + exit 255; + }); + + $0 =~ s/-runner/-scheduler/i; + + my $state = $self->state; + + my $lock = open_file($self->dispatch_lock_file, '>>'); + + while (1) { + $state->poll; + + flock($lock, LOCK_EX) or die "Could not get scheduler lock: $!"; + + while (1) { + next if $state->advance; + last; + } + + flock($lock, LOCK_UN) or die "Could not release scheduler lock: $!"; + + if ($self->end_test_loop()) { + $guard->dismiss; + exit(0); + } + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + warn "Escaped scheduler loop"; + exit 255; +} + +sub run_tests { + my $self = shift; + + my $preloader = $self->preloader; + $preloader->preload(); + + $self->spawn_scheduler(); + + my ($stage, @procs) = $preloader->preload_stages(); + + if ($self->dump_depmap) { + if (my $dtrace = $preloader->dtrace) { + if (my $depmap = $dtrace->dep_map) { + my $file = "depmap-$stage.json"; + write_file($file, encode_json($depmap)); + } + } + } + + $self->watch($_) for @procs; + + while(1) { + $self->{+CAN_STAGE} = 1; + my $jump = setjump "Stage-Runner" => sub { + $self->run_stage($stage); + }; + + last unless $jump; + + ($stage) = @$jump; + $self->reset_stage(); + } + + return; +} + +sub reset_stage { + my $self = shift; + + # Normalize IPC + $self->check_for_fork(); + + # If no stage was set we do not want to clear this, root stages need to + # preserve the preloads + return unless $self->{+STAGE}; + + # From Runner + delete $self->{+STAGE}; + delete $self->{+STATE}; + delete $self->{+LAST_TIMEOUT_CHECK}; + + return; +} + +sub run_stage { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE} = $stage; + $self->state->stage_ready($stage); + + while (1) { + next if $self->run_job(); + + next if $self->wait(); + + last if $self->end_test_loop(); + + sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; + } + + $self->state->stage_down($stage); + + $self->killall($self->{+SIGNAL}) if $self->{+SIGNAL}; + + $self->wait(all => 1); + + exit 0 unless $stage eq 'base' || $stage eq 'default'; +} + +sub run_job { + my $self = shift; + + my $task = $self->state->next_task($self->{+STAGE}) or return 0; + + if ($task->{spawn} && !$task->{resource_skip}) { + my $job = Test2::Harness::Runner::Spawn->new( + runner => $self, + task => $task, + settings => $self->settings, + fork_callback => $self->{+FORK_SPAWN_CALLBACK}, + ); + + $self->{+FORK_SPAWN_CALLBACK}->($self, $job); + return 1; + } + + my $run = $self->state->run(); + return 1 unless $run; + + my $job_class; + if ($task->{job_class}) { + $job_class = $task->{job_class}; + require(mod2file($job_class)); + + die "Custom job class $job_class overrode the category, this is a fatal mistake" + unless $job_class->category eq $self->job_class->category; + } + else { + $job_class = $self->job_class; + } + + my $job = $job_class->new( + runner => $self, + task => $task, + run => $run, + settings => $self->settings, + fork_callback => $self->{+FORK_JOB_CALLBACK}, + ); + + $job->prepare_dir(); + + my $spawn_time; + + my $pid; + my $via = $job->via(); + if ($via) { + require(mod2file($1)) if !defined(&{$via}) && $via =~ m/^(.+)::[^:]+$/; + + $spawn_time = time(); + $pid = $self->$via($job); + $job->set_pid($pid); + $self->watch($job); + } + else { + $spawn_time = time(); + $self->spawn($job); + $pid = $job->pid; + } + + $run->add_job($job, $spawn_time); + + return $pid; +} + +sub end_test_loop { + my $self = shift; + + my $state = $self->state; + + no warnings 'uninitialized'; + if (!$self->{+STAGE} || $self->{+STAGE} eq 'default' || $self->{+STAGE} eq 'base') { + $self->{+RESPAWN_RUNNER_CALLBACK}->() + if $self->preloader->check($state) || ($self->{+SIGNAL} && $self->{+SIGNAL} eq 'HUP'); + } + + if ($self->preloader->check($state)) { + $self->{+SIGNAL} //= 'HUP'; + return 1; + } + + return 1 if $self->{+SIGNAL}; + + return 1 if $state->done; + + return 0; +} + +sub set_proc_exit { + my $self = shift; + my ($proc, $exit, $time, @args) = @_; + + if ($proc->isa('Test2::Harness::Runner::Job')) { + my $task = $proc->task; + + my $timed_out = 0; + if ( !$exit && ref $self->{run_reached_timeout} && $self->{run_reached_timeout}->{ $task->{job_id} } ) { + delete $self->{run_reached_timeout}->{ $task->{job_id} }; + $timed_out = 1; + } + + if (($exit || $timed_out) && $proc->is_try < $proc->retry ) { + $self->state->retry_task($task->{job_id}); + push @args => 'will-retry'; + } + else { + $self->state->stop_task($task->{job_id}); + } + + if(my $bail = $exit ? $proc->bailed_out : 0) { + print "$$ $0 BAIL-OUT detected: $bail\n"; + if ($self->settings->runner->abort_on_bail) { + print "$$ $0 Aborting the test run...\n"; + $self->state->halt_run($task->{run_id}); + } + } + } + elsif ($proc->isa('Test2::Harness::Runner::Preloader::Stage')) { + my $stage = $proc->name; + + if ($exit != 0) { + my $e = parse_exit($exit); + my $err = "$$ $0 Child stage '$stage' did not exit cleanly (sig: $e->{sig}, err: $e->{err})!\n"; + $self->{+MONITOR_PRELOADS} ? warn $err : die $err; + } + + if ($self->{+MONITOR_PRELOADS} && $self->{+CAN_STAGE} && !$self->end_test_loop) { + my $pid = $$; + my ($name, @procs) = $self->preloader->_preload_stages($stage); + $self->watch($_) for @procs; + longjump "Stage-Runner" => $name unless $pid == $$; + } + } + + $self->SUPER::set_proc_exit($proc, $exit, $time, @args); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner - Base class for test runners + +=head1 DESCRIPTION + +This module does the heavy lifting of running all the tests. + +You should never need to create an instance of the runner yourself. In most +cases the runner module is exposed via a callback or a plugin affordance. + +=head1 PUBLIC METHODS + +=head2 FROM SETTINGS + +These are attributesd with values set from the L<Test2::Harness::Settings> +instance created from command line arguments. + +See L<App::Yath::Options::Runner> for the most up to date documentation on +these. + +=over 4 + +=item $runner->includes + +=item $runner->tlib + +=item $runner->lib + +=item $runner->blib + +=item $runner->unsafe_inc + +=item $runner->use_fork + +=item $runner->preloads + +=item $runner->preload_threshold + +=item $runner->switches + +=item $runner->cover + +=item $runner->event_timeout + +=item $runner->post_exit_timeout + +=back + +=head2 FROM CONSTRUCTION + +These attributes are set when the runner is created. + +=over 4 + +=item $path = $runner->dir + +Path to the working directory. + +=item $settings = $runner->settings + +The L<App::Yath::Settings> instance. + +=item $coderef = $runner->fork_job_callback + +Callback used to spawn new tests via fork. + +=item $coderef = $runner->respawn_runner_callback + +Callback to restart the runner process. + +=item $bool = $runner->monitor_preloads + +True if preloads should be watched for changes. + +=item $int = $runner->jobs_todo + +A count of total jobs to run. This will always be 0 in a persistent runner. + +=back + +=head2 OTHER PUBLIC METHODS + +If a method is not documented here then it is an implementation detail and you +should not use it. + +=over 4 + +=item $class = $runner->job_class + +Class for new test jobs. + +=item $preload = $runner->preloader + +Get the L<Test2::Harness::Runner::Preloader> instance. + +=item $state = $runner->state + +Get the L<Test2::Harness::Runner::State> instance. + +=item @list = $runner->all_libs + +Get all the libs that should be added to @INC by default. Note that specific +runs and even specific tests can have custom paths on top of these. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Constants.pm b/liby/Test2/Harness/Runner/Constants.pm new file mode 100644 index 000000000..ce20a0380 --- /dev/null +++ b/liby/Test2/Harness/Runner/Constants.pm @@ -0,0 +1,72 @@ +package Test2::Harness::Runner::Constants; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT = qw/CATEGORIES DURATIONS/; + +use constant CATEGORIES => {general => 1, isolation => 1, immiscible => 1}; +use constant DURATIONS => {long => 1, medium => 1, short => 1}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Constants - Constants shared between multiple runner +modules. + +=head1 DESCRIPTION + +Export some common structures. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::Constants qw/CATEGORIES DURATIONS/; + + if (CATEGORIES->{$cat}) { + print "$cat is valid\n"; + } + else { + print "$cat is not valid\n"; + } + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/DepTracer.pm b/liby/Test2/Harness/Runner/DepTracer.pm new file mode 100644 index 000000000..301ad0855 --- /dev/null +++ b/liby/Test2/Harness/Runner/DepTracer.pm @@ -0,0 +1,283 @@ +package Test2::Harness::Runner::DepTracer; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::HashBase qw/ + -_on + -exclude + -dep_map + -loaded + -my_require + -real_require + -_my_inc + -callbacks +/; + +my %DEFAULT_EXCLUDE = ( + 'warnings.pm' => 1, + 'strict.pm' => 1, +); + +my $ACTIVE; + +sub ACTIVE { $ACTIVE } + +sub start { + my $self = shift; + + croak "There is already an active DepTracer" if $ACTIVE; + + $ACTIVE = $self; + + unshift @INC => $self->my_inc; + + $self->{+_ON} = 1; +} + +sub stop { + my $self = shift; + + croak "DepTracer is not active" unless $ACTIVE; + croak "Different DepTracer is active" unless "$ACTIVE" eq "$self"; + $ACTIVE = undef; + + $self->{+_ON} = 0; + + my $inc = $self->{+_MY_INC} or return 0; + + @INC = grep { !(ref($_) && $inc == $_) } @INC; + return 0; +} + +sub my_inc { + my $self = shift; + + return $self->{+_MY_INC} if $self->{+_MY_INC}; + + my $exclude = $self->{+EXCLUDE} ||= {%DEFAULT_EXCLUDE}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + + return $self->{+_MY_INC} ||= sub { + my ($this, $file) = @_; + + return unless $self->{+_ON}; + return unless $file =~ m/^[_a-z]/i; + return if $exclude->{$file}; + + my $loaded_by = $self->loaded_by; + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + + return; + }; +} + +sub clear_loaded { %{$_[0]->{+LOADED}} = () } + +my %REQUIRE_CACHE; + +sub add_callbacks { + my $self = shift; + my %watch = @_; + for my $file (keys %watch) { + my $cb = $watch{$file}; + $self->add_callback($file => $cb); + } +} + +sub add_callback { + my $self = shift; + my ($file, $cb) = @_; + $self->{+LOADED}->{$file}++; + $self->{+CALLBACKS}->{$file} = $cb; +} + +sub init { + my $self = shift; + + my $exclude = $self->{+EXCLUDE} ||= { %DEFAULT_EXCLUDE }; + + my $stash = \%CORE::GLOBAL::; + # We use a string in the reference below to prevent the glob slot from + # being auto-vivified by the compiler. + $self->{+REAL_REQUIRE} = exists $stash->{require} ? \&{'CORE::GLOBAL::require'} : undef; + + $self->{+CALLBACKS} //= {}; + my $dep_map = $self->{+DEP_MAP} ||= {}; + my $loaded = $self->{+LOADED} ||= {}; + my $inc = $self->my_inc; + + my $require = $self->{+MY_REQUIRE} = sub { + my ($file) = @_; + + my $loaded_by = $self->loaded_by; + + my $real_require = $self->{+REAL_REQUIRE}; + unless($real_require) { + my $caller = $loaded_by->[0]; + $real_require = $REQUIRE_CACHE{$caller} ||= eval "package $caller; sub { CORE::require(\$_[0]) }" or die $@; + } + + goto &$real_require unless $self->{+_ON}; + + if ($file =~ m/^[_a-z]/i) { + unless ($exclude->{$file}) { + push @{$dep_map->{$file}} => $loaded_by; + $loaded->{$file}++; + } + } + + if (!ref($INC[0]) || $INC[0] != $inc) { + @INC = ( + $inc, + grep { !(ref($_) && $inc == $_) } @INC, + ); + } + + local @INC = @INC[1 .. $#INC]; + + $real_require->(@_); + }; + + { + no strict 'refs'; + no warnings 'redefine'; + *{'CORE::GLOBAL::require'} = $require; + } +} + +sub loaded_by { + my $level = 1; + + while(my @caller = caller($level++)) { + next if $caller[0] eq __PACKAGE__; + + return [$caller[0], $caller[1]]; + } + + return ['', '']; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::DepTracer - Tool for tracing module dependencies as +they are loaded. + +=head1 DESCRIPTION + +This tool is used by Test2::Harness to build a graph of dependancies which can +then be used to blacklist modified modules (and anything thatuses them) when +they change under a preloaded runner. + +=head1 SYNOPSIS + + use Test2::Harness::Runner::DepTracer; + + my $dt = Test2::Harness::Runner::DepTracer->new(); + + $dt->start(); + + require Some::Thing; + + # You can always check for and retrieve an active DepTrace this way: + my $dt_reference = Test2::Harness::Runner::DepTracer->ACTIVE; + + $dt->stop(); + + my $dep_map = $dt->dep_map; + + my $loaded_by = $dep_map->{'Some/Thing.pm'}; + print "Some::Thing was directly or indirectly loaded by:\n" . join("\n" => @$loaded_by) . "\n"; + +=head1 ATTRIBUTES + +These can be specified at construction, and will be populated during use. + +=over 4 + +=item $hashref = $dt->exclude + +A hashref of files/modules to exclude from dep tracking. By default C<strict> +and C<warnings> are excluded. + +=item $hashref = $dt->dep_map + +Every file which is loaded while the tool is started will have an entry in this +hash, each value is an array of all files which loaded the key file directly or +indirectly. + +=item $hashref = $dt->loaded + +How many times each file was directly loaded. + +=back + +=head1 METHODS + +=over 4 + +=item $dt->start + +Start tracking modules which are loaded. + +=item $dt->stop + +Stop tracking moduels that are loaded. + +=back + +=head1 CLASS METHODS + +=over 4 + +=item $dt_or_undef = Test2::Harness::Runner::DepTracer->ACTIVE(); + +Get the currently active DepTracer, if any. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Job.pm b/liby/Test2/Harness/Runner/Job.pm new file mode 100644 index 000000000..ec2378382 --- /dev/null +++ b/liby/Test2/Harness/Runner/Job.pm @@ -0,0 +1,828 @@ +package Test2::Harness::Runner::Job; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess croak/; +use Config qw/%Config/; +use List::Util qw/min/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/CAN_REALLY_FORK/; +use Time::HiRes qw/time/; + +use File::Spec(); +use File::Temp(); + +use Test2::Harness::Util qw/fqmod clean_path write_file_atomic write_file mod2file open_file parse_exit process_includes chmod_tmp/; +use Test2::Harness::IPC; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase( + qw{ <task <runner <run <settings }, # required + qw{ + <fork_callback + <last_output_size + +output_changed + + +verbose + + +via + + +run_dir +job_dir +tmp_dir +event_dir + + +ch_dir +unsafe_inc + + +use_fork +use_w_switch + + +includes +runner_includes + +switches + +use_stream + +cli_includes + +cli_options + + +smoke + +retry +retry_isolated +is_try + + +args +file +run_file + + +out_file +err_file +in_file +bail_file + + +load +load_import + + +event_uuids +mem_usage +io_events + + +env_vars + + +event_timeout +post_exit_timeout +use_timeout + + +switches_from_env + + +et_file +pet_file + + +min_slots + +max_slots + } +); + +sub category { 'job' } + +sub init { + my $self = shift; + + croak "'runner' is a required attribute" unless $self->{+RUNNER}; + croak "'run' is a required attribute" unless $self->{+RUN}; + croak "'settings' is a required attribute" unless $self->{+SETTINGS}; + + delete $self->{+JOB_DIR}; + + # Avoid a ref cycle + #weaken($self->{+RUNNER}); + + my $task = $self->{+TASK} or croak "'task' is a required attribute"; + + delete $self->{+LAST_OUTPUT_SIZE}; + + confess "Task does not have a job ID" unless $task->{job_id}; + confess "Task does not have a file" unless $task->{file}; +} + +sub job_id { $_[0]->{+TASK}->{job_id} } + +sub prepare_dir { + my $self = shift; + + $self->job_dir(); + $self->tmp_dir(); + $self->event_dir(); +} + +sub via { + my $self = shift; + + return undef if $self->{+SETTINGS}->debug->dummy; + return undef if $self->{+TASK}->{resource_skip}; + + return $self->{+VIA} if exists $self->{+VIA}; + + my $task = $self->{+TASK}; + return $self->{+VIA} = $task->{via} if $task->{via}; + + return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork; + + return $self->{+VIA} = undef; +} + +sub spawn_params { + my $self = shift; + + my $task = $self->{+TASK}; + + my $skip; + $skip = 'dummy mode' if $self->{+SETTINGS}->debug->dummy; + $skip = "Some resources are not available: " . join(', ' => @{$self->{+TASK}->{resource_skip}}) if $self->{+TASK}->{resource_skip}; + + my $command; + if (!$skip && $task->{binary} || $task->{non_perl}) { + my $file = $self->ch_dir ? $self->file : $self->rel_file; + $command = [clean_path($file), $self->args]; + } + else { + $command = [ + $^X, + $self->cli_includes, + $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (), + $self->switches, + $self->cli_options, + + $skip ? ('-e', "print \"1..0 # SKIP $skip\"") : (sub { $self->run_file }), + + $self->args, + ]; + } + + my $out_fh = open_file($self->out_file, '>'); + my $err_fh = open_file($self->err_file, '>'); + my $in_fh = open_file($self->in_file, '<'); + + return { + command => $command, + stdin => $in_fh, + stdout => $out_fh, + stderr => $err_fh, + chdir => $self->ch_dir(), + env => $self->env_vars(), + }; +} + +sub switches_from_env { + my $self = shift; + + return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV}; + + return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES}; + + return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]}; +} + +my %JSON_SKIP = ( + SETTINGS() => 1, + TASK() => 1, + RUNNER() => 1, + RUN() => 1, + CLI_INCLUDES() => 1, + CLI_OPTIONS() => 1, + ERR_FILE() => 1, + ET_FILE() => 1, + EVENT_DIR() => 1, + EXIT() => 1, + EXIT_TIME() => 1, + IN_FILE() => 1, + JOB_DIR() => 1, + LAST_OUTPUT_SIZE() => 1, + OUT_FILE() => 1, + BAIL_FILE() => 1, + OUTPUT_CHANGED() => 1, + PET_FILE() => 1, + RUN_DIR() => 1, + TMP_DIR() => 1, +); + +sub TO_JSON { + my $self = shift; + + my $out = { %{$self->{+TASK}} }; + + for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) { + next if $JSON_SKIP{$attr}; + $self->$attr unless defined $self->{$attr}; + $out->{$attr} = $self->{$attr}; + } + + delete $out->{+FORK_CALLBACK}; + delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE'; + + $out->{job_name} //= $out->{job_id}; + $out->{abs_file} = clean_path($self->file); + + return $out; +} + +sub run_file { + my $self = shift; + return $self->{+RUN_FILE} //= $self->rel_file; +} + +sub rel_file { File::Spec->abs2rel($_[0]->file) } +sub file { $_[0]->{+FILE} //= clean_path($_[0]->{+TASK}->{file}, 0) } +sub err_file { $_[0]->{+ERR_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) } +sub out_file { $_[0]->{+OUT_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) } +sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) } +sub et_file { $_[0]->{+ET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) } +sub pet_file { $_[0]->{+PET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) } +sub run_dir { $_[0]->{+RUN_DIR} //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) } + +sub bailed_out { + my $self = shift; + + if(-f $self->bail_file) { + my $fh = open_file($self->bail_file, '<'); + my $reason = <$fh> || 1; + return $reason; + } + + my $fh = open_file($self->out_file, '<'); + while (my $line = <$fh>) { + next unless $line =~ m/^Bail out!\s*(.*)$/; + return $1 || 1; + } + + return ""; +} + +sub output_size { + my $self = shift; + + my $size = 0; + + $size += -s $self->err_file || 0; + $size += -s $self->out_file || 0; + + return $self->{+LAST_OUTPUT_SIZE} = $size; +} + +sub output_changed { + my $self = shift; + + my $last = $self->{+LAST_OUTPUT_SIZE}; + my $size = $self->output_size(); + + # Output changed, update time + return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last; + + # Return the last recorded time, if there is no previously recorded time then the record starts now + return $self->{+OUTPUT_CHANGED} //= time(); +} + +sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 } +sub is_try { $_[0]->{+IS_TRY} //= $_[0]->{+TASK}->{is_try} // 0 } +sub ch_dir { $_[0]->{+CH_DIR} //= $_[0]->{+TASK}->{ch_dir} // '' } +sub unsafe_inc { $_[0]->{+UNSAFE_INC} //= $_[0]->{+RUNNER}->unsafe_inc } +sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids } +sub mem_usage { $_[0]->{+MEM_USAGE} //= $_[0]->run->mem_usage } + +sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) } + +sub smoke { $_[0]->{+SMOKE} //= $_[0]->_fallback(smoke => 0, qw/task/) } +sub retry_isolated { $_[0]->{+RETRY_ISOLATED} //= $_[0]->_fallback(retry_isolated => 0, qw/task run/) } +sub use_stream { $_[0]->{+USE_STREAM} //= $_[0]->_fallback(use_stream => 1, qw/task run/) } +sub use_timeout { $_[0]->{+USE_TIMEOUT} //= $_[0]->_fallback(use_timeout => 1, qw/task/) } +sub retry { $_[0]->{+RETRY} //= $_[0]->_fallback(retry => undef, qw/task run/) } +sub event_timeout { $_[0]->{+EVENT_TIMEOUT} //= $_[0]->_fallback(event_timeout => undef, qw/task runner/) } +sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) } + +sub min_slots { $_[0]->{+MIN_SLOTS} //= $_[0]->_fallback_non_bool(min_slots => 1, qw/task/) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_fallback_non_bool(max_slots => 1, qw/task/) } + +sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} } +sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} } + +sub cli_includes { + my $self = shift; + + # '.' is handled via the PERL_USE_UNSAFE_INC env var set later + $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes]; + + return @{$self->{+CLI_INCLUDES}}; +} + +sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} } + +sub _merge_sources { + my $self = shift; + my ($name, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + next unless defined $val; + next unless @$val; + push @vals => @$val; + } + + return \@vals; +} + +sub _fallback_non_bool { + my $self = shift; + my ($name, $default, @from) = @_; + + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + return $val if defined $val; + } + + return $default; +} + +sub _fallback { + my $self = shift; + my ($name, $default, @from) = @_; + + my @vals; + for my $from (@from) { + my $source = $self->$from; + my $val = blessed($source) ? $source->$name : $source->{$name}; + push @vals => $val if defined $val; + } + + return $default unless @vals; + + # If the default is a ref we will just return the first value we found, truthiness check is useless + return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/; + + # If the default is true, then we only return true if none of the vals are false + return !grep { !$_ } @vals if $default; + + # If the default is false, then we return true if any of the valse are true + return grep { $_ } @vals; +} + +sub job_dir { + my $self = shift; + return $self->{+JOB_DIR} if $self->{+JOB_DIR}; + + my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try); + mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!"; + chmod_tmp($job_dir); + $self->{+JOB_DIR} = $job_dir; +} + +sub tmp_dir { + my $self = shift; + + return $self->{+TMP_DIR} if $self->{+TMP_DIR}; + + my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir); + chmod_tmp($tmp_dir); + + $self->{+TMP_DIR} = clean_path($tmp_dir); +} + +sub make_event_dir { $_[0]->event_dir } +sub event_dir { + my $self = shift; + return $self->{+EVENT_DIR} if $self->{+EVENT_DIR}; + + my $events_dir = File::Spec->catdir($self->job_dir, 'events'); + unless (-d $events_dir) { + mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!"; + } + $self->{+EVENT_DIR} = $events_dir; +} + +sub in_file { + my $self = shift; + return $self->{+IN_FILE} if $self->{+IN_FILE}; + + my $task = $self->{+TASK}; + + unless ($task->{input}) { + my $from_run = $self->run->input_file; + return $self->{+IN_FILE} = $from_run if $from_run; + } + + my $stdin = File::Spec->catfile($self->job_dir, 'stdin'); + + my $content = $task->{input} // $self->run->input // ''; + write_file($stdin, $content); + + return $self->{+IN_FILE} = $stdin; +} + +sub use_fork { + my $self = shift; + + return $self->{+USE_FORK} if defined $self->{+USE_FORK}; + + my $task = $self->{+TASK}; + + return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK; + return $self->{+USE_FORK} = 0 if $task->{binary}; + return $self->{+USE_FORK} = 0 if $task->{non_perl}; + return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork}; + return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload}; + + # -w switch is ok, otherwise it is a no-go + return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches; + + my $runner = $self->{+RUNNER}; + return $self->{+USE_FORK} = 0 unless $runner->use_fork; + + return $self->{+USE_FORK} = 1; +} + +sub includes { + my $self = shift; + + return @{$self->{+INCLUDES}} if $self->{+INCLUDES}; + + $self->{+INCLUDES} = [ + process_includes( + list => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}], + include_dot => $self->unsafe_inc, + include_current => 1, + clean => 1, + $self->ch_dir ? (ch_dir => $self->ch_dir) : (), + ) + ]; + + return @{$self->{+INCLUDES}}; +} + +sub cli_options { + my $self = shift; + + my $event_dir = $self->event_dir; + my $job_id = $self->job_id; + + return ( + $self->use_stream ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (), + $self->event_uuids ? ('-MTest2::Plugin::UUID') : (), + $self->mem_usage ? ('-MTest2::Plugin::MemUsage') : (), + $self->io_events ? ('-MTest2::Plugin::IOEvents') : (), + (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import), + (map { "-m$_" } $self->load), + ); +} + +sub switches { + my $self = shift; + + return @{$self->{+SWITCHES}} if $self->{+SWITCHES}; + + my @switches; + + my %seen; + for my $s (@{$self->{+TASK}->{switches} // []}) { + $seen{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + my %seen2; + for my $s (@{$self->{+RUNNER}->switches // []}) { + next if $seen{$s}; + $seen2{$s}++; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + for my $s ($self->switches_from_env) { + next if $seen{$s}; + next if $seen2{$s}; + $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; + push @switches => $s; + } + + return @{$self->{+SWITCHES} = \@switches}; +} + +sub prof_file { + my $self = shift; + my $file =$self->rel_file; + + $file =~ s{/}{-}g; + $file =~ s{\.[^\.]+$}{.nytprof}g; + + return $file; +} + +sub env_vars { + my $self = shift; + + return $self->{+ENV_VARS} if $self->{+ENV_VARS}; + + my $from_run = $self->run->env_vars; + my $from_task = $self->{+TASK}->{env_vars}; + + my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB}); + push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl}; + push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB}; + my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l; + + my $verbose = $self->verbose; + + return $self->{+ENV_VARS} = { + $from_run ? (%$from_run) : (), + $from_task ? (%$from_task) : (), + + $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (), + + $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (), + + PERL5LIB => $p5l, + PERL_USE_UNSAFE_INC => $self->unsafe_inc, + TEST2_JOB_DIR => $self->job_dir, + TEST2_RUN_DIR => $self->run_dir, + TMPDIR => $self->tmp_dir, + TEMPDIR => $self->tmp_dir, + SYSTEM_TMPDIR => $self->{+SETTINGS}->harness->orig_tmp, + SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms, + + HARNESS_IS_VERBOSE => $verbose, + T2_HARNESS_IS_VERBOSE => $verbose, + + HARNESS_ACTIVE => 1, + TEST2_HARNESS_ACTIVE => 1, + + T2_HARNESS_JOB_FILE => $self->rel_file, + T2_HARNESS_JOB_NAME => $self->{+TASK}->{job_name}, + T2_HARNESS_JOB_IS_TRY => $self->{+IS_TRY} // 0, + T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '', + }; +} + +sub load_import { + my $self = shift; + + return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT}; + + my $from_run = $self->run->load_import; + + my @out; + for my $mod (@{$from_run->{'@'} // []}) { + push @out => [$mod, $from_run->{$mod} // []]; + } + + return @{$self->{+LOAD_IMPORT} = \@out}; +} + +sub use_w_switch { + my $self = shift; + return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH}; + $self->switches; + return $self->{+USE_W_SWITCH}; +} + +sub set_exit { + my $self = shift; + my ($runner, $exit, $time, @args) = @_; + + $self->SUPER::set_exit(@_); + + my $file = File::Spec->catfile($self->job_dir, 'exit'); + + my $e = parse_exit($exit); + + write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Job - Representation of a test job. + +=head1 DESCRIPTION + +This module takes all the data from a test file queue item, a run, and runner +settings, and mashes them together to figure out what is actually needed to run +a job. + +=head1 METHODS + +Note, this object subclasses L<Test2::Harness::IPC::Process>. + +=over 4 + +=item $arrayref = $job->args + +Get the arguments for the test either formt he queue item, or from the run. + +=item $path = $job->bail_file + +Path to the events-file used in case of a bail-out + +=item $bool = $job->bailed_out + +True if the test job bailed out. + +=item $cat $job->category + +Process category, always 'job' unless overriden in a subclass. + +=item $path = $job->ch_dir + +If this job first requires a change in directory before running, this will +return the path. + +=item @list = $job->cli_includes + +List of includes for a command line launch of this job. + +=item @list = $job->cli_options + +List of options for a command line launch of this job. + +=item $hashref = $job->env_vars + +Get environment variables to set when launching this job. + +=item $path = $job->out_file + +File to which all STDOUT for the job will be written. + +=item $path = $job->err_file + +File to which all STDERR for the job will be written. + +=item $path = $job->et_file + +File to which event timeout notifications will be written. + +=item $path = $job->pet_file + +File to which post exit timeout events will be written. + +=item $path = $job->event_dir + +Directory to which L<Test2::Formatter::Stream> events will be written. + +=item $time = $job->event_timeout + +Event timeout specification, if any, first from test queue item, then from +runner. + +=item $time = $job->post_exit_timeout + +Post exit timeout specification, if any, first from test queue item, then from +runner. + +=item $bool = $job->event_uuids + +Use L<Test2::Plugin::UUID> inside the test. + +=item $path = $job->file + +Test file the job will be running. + +=item $coderef = $job->fork_callback + +If the job is to be launched via fork, use this callback. + +=item $path = $job->in_file + +File containing STDIN to be provided to the test. + +=item @list = $job->includes + +Paths to add to @INC for the test. + +=item $bool = $job->io_events + +True if L<Test2::Plugin::IOEvents> should be used. + +=item $int = $job->is_try + +This starts at 0 and will be incremented for every retry of the job. + +=item $path = $job->job_dir + +Temporary directory housing all files related to this job when it runs. + +=item $uuid = $job->job_id + +UUID for this job. + +=item @list = $job->load + +Modules to load when starting this job. + +=item @list = $job->load_import + +Modules to load and import when starting this job. + +=item $bool = $job->mem_usage + +True if the L<Test2::Plugin::MemUsage> plugin should be used. + +=item $path = $job->run_file + +Usually the same as rel_file, but you can specify an alternative file to +actually run. + +=item $path = $job->rel_file + +Relative path to the file. + +=item $int = $job->retry + +How many times the test should be retried if it fails. + +=item $bool = $job->retry_isolated + +True if the test should be retried in isolation if it fails. + +=item $run = $job->run + +The L<Test2::Harness::Runner::Run> instance. + +=item $path = $job->run_dir + +Path to the temporary directory housing all the data about the run. + +=item $runner = $job->runner + +The L<Test2::Harness::Runner> instance. + +=item @list = $job->runner_includes + +Search path includes provided directly by the runner. + +=item $settings = $job->settings + +The L<Test2::Harness::Settings> instance. + +=item $bool = $job->smoke + +True if the test is a priority smoke test. + +=item $hashref = $job->spawn_params + +Parameters for C<run_cmd()> in L<Test2::Harness::Util::IPC> when launching this +job. + +=item @list = $job->switches + +Command line switches for perl when running this test. + +=item $hashref = $job->task + +Task data from the queue. + +=item $path = $job->tmp_dir + +Temp dir created specifically for this job. + +=item $bool = $job->unsafe_inc + +True if '.' should be added to C<@INC>. + +=item $bool = $job->use_fork + +True if this job should be launched via fork. + +=item $bool = $job->use_stream + +True if this job should use L<Test2::Formatter::Stream>. + +=item $bool = $job->use_timeout + +True if this job should timeout due to lack of activity. + +=item $bool = $job->use_w_switch + +True if the C<-w> switch should be used for this test. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Preload.pm b/liby/Test2/Harness/Runner/Preload.pm new file mode 100644 index 000000000..f09708fc7 --- /dev/null +++ b/liby/Test2/Harness/Runner/Preload.pm @@ -0,0 +1,569 @@ +package Test2::Harness::Runner::Preload; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Runner::Preload::Stage(); + +sub import { + my $class = shift; + my $caller = caller; + + my %exports; + + my $instance = $class->new; + + $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; + + $exports{stage} = sub { + my ($name, $code) = @_; + my @caller = caller(); + $instance->build_stage( + name => $name, + code => $code, + caller => \@caller, + ); + }; + + $exports{eager} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_eager(1); + }; + + $exports{default} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + my $name = $stage->name; + $instance->set_default_stage($name); + }; + + $exports{file_stage} = sub { + my ($callback) = @_; + my @caller = caller(); + croak "'file_stage' cannot be used under a stage" if @{$instance->stack}; + $instance->add_file_stage(\@caller, $callback); + }; + + for my $name (qw/pre_fork post_fork pre_launch/) { + my $meth = "add_${name}_callback"; + $exports{$name} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->$meth(@_); + }; + } + + $exports{watch} = sub { + if (@{$instance->stack}) { + my $stage = $instance->stack->[-1]; + return $stage->watch(@_); + } + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + return $active->add_callback(@_); + } + } + + croak "No current stage, and no active deptracer"; + }; + + $exports{preload} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->add_to_load_sequence(@_); + }; + + $exports{reload_remove_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_remove_check(@_); + }; + + $exports{reload_inplace_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_inplace_check(@_); + }; + + for my $name (keys %exports) { + no strict 'refs'; + *{"$caller\::$name"} = $exports{$name}; + } +} + +use Test2::Harness::Util::HashBase qw{ + <stage_list + <stage_lookup + <stack + +default_stage + +file_stage +}; + +sub init { + my $self = shift; + + $self->{+STAGE_LIST} //= []; + $self->{+STAGE_LOOKUP} //= {}; + + $self->{+STACK} //= []; + + $self->{+FILE_STAGE} //= []; +} + +sub build_stage { + my $self = shift; + my %params = @_; + + my $caller = $params{caller} //= [caller()]; + + die "A coderef is required at $caller->[1] line $caller->[2].\n" + unless $params{code}; + + my $stage = Test2::Harness::Runner::Preload::Stage->new( + stage_lookup => $self->{+STAGE_LOOKUP}, + %params, + ); + + my $stack = $self->{+STACK} //= []; + push @$stack => $stage; + + my $ok = eval { $params{code}->($stage); 1 }; + my $err = $@; + + die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; + + pop @$stack; + + die $err unless $ok; + + if (@$stack) { + $stack->[-1]->add_child($stage); + } + else { + $self->add_stage($stage, $caller); + } + + return $stage; +} + +sub add_stage { + my $self = shift; + my ($stage, $caller) = @_; + + $caller //= [caller()]; + + my @all = ($stage, @{$stage->all_children}); + + for my $item (@all) { + my $name = $item->name; + + if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { + $caller //= [caller()]; + my $ncaller = $item->frame; + my $ecaller = $existing->frame; + die <<" EOT" +A stage named '$name' was already defined. + First at $ecaller->[1] line $ecaller->[2]. + Second at $ncaller->[1] line $ncaller->[2]. + Mixed at $caller->[1] line $caller->[2]. + EOT + } + + $self->{+STAGE_LOOKUP}->{$name} = $item; + } + + push @{$self->{+STAGE_LIST}} => $stage; +} + +sub merge { + my $self = shift; + my ($merge) = @_; + + my $caller = [caller()]; + + for my $stage (@{$merge->{+STAGE_LIST}}) { + $self->add_stage($stage, $caller); + } + + push @{$self->{+FILE_STAGE}} => @{$merge->{+FILE_STAGE}}; + + $self->{+DEFAULT_STAGE} //= $merge->default_stage; +} + +sub add_file_stage { + my $self = shift; + my ($caller, $code) = @_; + + croak "Caller must be defined and an array" unless $caller && ref($caller) eq 'ARRAY'; + croak "Code must be defined and a coderef" unless $code && ref($code) eq 'CODE'; + + push @{$self->{+FILE_STAGE}} => [$caller, $code]; +} + +sub file_stage { + my $self = shift; + my ($file) = @_; + + for my $cb (@{$self->{+FILE_STAGE}}) { + my ($caller, $code) = @$cb; + my $stage = $code->($file) or next; + + die "file_stage callback returned invalid stage: $stage at $caller->[1] line $caller->[2].\n" + unless $self->{+STAGE_LOOKUP}->{$stage}; + + return $stage; + } + + return; +} + +sub default_stage { + my $self = shift; + return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; + return $self->{+STAGE_LIST}->[0]; +} + +sub set_default_stage { + my $self = shift; + my ($name) = @_; + + croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; + $self->{+DEFAULT_STAGE} = $name; +} + +sub eager_stages { + my $self = shift; + + my %eager; + + for my $root (@{$self->{+STAGE_LIST}}) { + for my $stage ($root, @{$root->all_children}) { + next unless $stage->eager; + $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; + } + } + + return \%eager; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload - DSL for building complex stage-based preload +tools. + +=head1 DESCRIPTION + +L<Test2::Harness> allows you to preload libraries for a performance boost. This +module provides tools that let you go beyond that and build a more complex +preload. In addition you can build multiple preload I<stages>, each stage will +be its own process and tests can run from a specific stage. This allows for +multiple different preload states from which to run tests. + +=head1 SYNOPSIS + +=head2 USING YOUR PRELOAD + +The C<-P> or C<--preload> options work for custom preload modules just as they +do regular modules. Yath will know the difference and act accordingly. + + yath test -PMy::Preload + +=head2 WRITING YOUR PRELOAD + + package My::Preload; + use strict; + use warnings; + + # This imports several useful tools, and puts the necessary meta-data in + # your package to identify it as a special preload. + use Test2::Harness::Runner::Preload; + + # You must specify at least one stage. + stage Moose => sub { + # Preload can be called multiple times, and can load multiple modules + # per call. Order is preserved. + preload 'Moose', 'Moose::Role'; + preload 'Scalar::Util', 'List::Util'; + + # preload can also be given a sub if you have some custom code to run + # at a specific point in the load order + preload sub { + # Do something before loading Try::Tiny + ... + }; + + preload 'Try::Tiny'; + + # Tell the runner to watch this file for changes, if it does change run + # the sub instead of the usual reload process. This lets you reload + # configs and other non-perl files, or allows you to use a custom + # reload sub for perl files. + watch 'path/to/file' => sub { ... }; + + # You can also use watch inside preload subs: + preload sub { + watch 'path/to/file' => sub { ... }; + }; + + # In app code you can add watches dynamically when applicable: + preload sub { + ... # inside app code + + if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { + if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { + $active->add_callback('path/to/file' => sub { ... }); + } + } + + ... + }; + + # Eager means tests from nested stages can be run in this stage as + # well, this is useful if the nested stage takes a long time to load as + # it allows yath to start running tests sooner instead of waiting for + # the stage to finish loading. Once the nested stage is loaded tests + # intended for it will start running from it instead. + eager(); + + # default means this stage is the one to use if the test does not + # specify a stage. + default(); + + # These are hooks that let you run arbitrary code at specific points in + # the process. pre_fork happens just before forking to run a test. + # post_fork happens just after forking for a test. pre_launch happens + # as late as possible before the test starts executing (post fork, + # after $0 and other special state are reset). + pre_fork sub { ... }; + post_fork sub { ... }; + pre_launch sub { ... }; + + # Stages can be nested, nested ones build off the previous stage, but + # are in a forked process to avoid contaminating the parent. + stage Types => sub { + preload 'MooseX::Types'; + }; + }; + + # Alternative stage that loads Moo instead of Moose + stage Moo => sub { + preload 'Moo'; + + ... + }; + +=head2 HARNESS DIRECTIVES IN PRELOADS + +If you use a staged preload, and the --reload option, you can add 'CHURN' +directives to files in order to only reload sections you are working on. This +is particularly useful when a file cannot be reloaded in full, or when doing so +is expensive. You can wrap subroutines in the churn directives to have yath +reload only those subroutines. + + sub do_not_reload_this { ... { + + # HARNESS-CHURN-START + + sub reload_this_one { + ... + } + + sub reload_this_one_too { + ... + } + + # HARNESS-CHURN-STOP + + sub this_is_not_reloaded { ... } + +You can put as many churn sections you want in as many preloaded modules as you +want. If a change is detected then only the churn sections will be reloaded. +The churn sections are reloaded by taking the source between the start and stop +markers, and running them in an eval like this: + + eval <<EOT + package MODULE_FROM_FILENAME; + use strict; + use warnings; + no warnings 'redefine'; + #line $line_number $file + $YOUR_CODE + ;1; + EOT + +In most cases this is sufficient to replace the old sub with the new one. If +the automatically determined package is not correct you can add a C<package +FOO;> statement inside the markers. If the strict/warnings settings are not to +your specifications you can add overrides inside the markers. Any valid perl +code can go into the markers. + +B<CAVEATS:> Be aware they do not have their original scope, and that can lead +to problems if you are not paying attention. Variables outside your markers are +not accessible, and lexical variables put inside your markers will be "new" on +each reload, this can cause confusion if you have lexicals used by multiple +subs where some are inside churn blocks and others are not, so best not to do +that. Package variables work a bit better, but any assignment lines are re-run. +So C<our $FOO;> is fine (it does not change the value if it is set) but +C<our $FOO = ...> will reset the var on each reload. + +=head1 EXPORTS + +=over 4 + +=item $meta = TEST2_HARNESS_PRELOAD() + +=item $meta = $class->TEST2_HARNESS_PRELOAD() + +This export provides the meta object, which is an instance of this class. This +method being present is how Test2::Harness differentiates between a regular +module and a special preload library. + +=item stage NAME => sub { ... } + +This creates a new stage with the given C<NAME>, and then runs the coderef with +the new stage set as the I<active> one upon which the other function here will +operate. Once the coderef returns the I<active> stage is cleared. + +You may nest stages by calling this function again inside the codeblock. + +B<NOTE:> stage names B<ARE> case sensitive. This can be confusing when you +consider that most harness directives are all-caps. In the following case the +stage requested by the test and the stage defined in +the library are NOT the same. + +In a test file: + + # HARNESS-STAGE-FOO + +In a preload library: + + stage foo { ... } + +Harness directives are all-caps, however the user data portion need not be, +this is fine: + + # HARNESS-STAGE-foo + +However it is very easy to make the mistake of thinking it is case insensitive. +It is also easy to assume the 'foo' part of the harness directive must be all +caps. In many cases it is smart to make your stage names all-caps. + +=item preload $module_name + +=item preload @module_names + +=item preload sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +This adds modules to the list of libraries to preload. Order is preserved. You +can also add coderefs to execute arbitrary code between module loads. + +The coderef is called with no arguments, and its return is ignored. + +=item eager() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This marks the I<active> stage as being I<eager>. An eager stage will start +running tests for nested stages if it finds itself with no tests of its own to +run before the nested stage can finish loading. The idea here is to avoid +unused test slots when possible allowing for tests to complete sooner. + +=item default() + +This B<MUST> be called inside a C<stage()> builder coderef. + +This B<MUST> be called only once across C<ALL> stages in a given library. + +If multiple preload libraries are loaded then the I<first> default set (based +on load order) will be the default, others will notbe honored. + +=item $stage_name = file_stage($test_file) + +This is optional. If defined this callback will have a chance to look at all +files that are going to be run and assign them a stage. This may return undef +or an empty list if it does not have a stage to assign. + +If multiple preload libraries define file_stage callbacks they will be called +in order, the first one to return a stage name will win. + +If no file_stage callbacks provide a stage for a file then any harness +directives declaring a stage will be honored. If no stage is ever assigned then +the test will be run int he default stage. + +=item pre_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before the preload-stage process forks to run the +test. Note that any state changes here can effect future tests to be run. + +=item post_fork sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just after the preload-stage process forks to run the +test. This is run as early as possible, things like C<$0> may not be set +properly yet. + +=item pre_launch sub { ... } + +This B<MUST> be called inside a C<stage()> builder coderef. + +Add a callback to be run just before control of the test process is turned over +to the test file itself. This is run as late as possible, so things like C<$0> +should be set properly. + +=back + +=head1 META-OBJECT + +This class is also the meta-object used to construct a preload library. The +methods are left undocumented as this is an implementation detail and you are +not intended to directly use this object. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Preload/Stage.pm b/liby/Test2/Harness/Runner/Preload/Stage.pm new file mode 100644 index 000000000..abba7a828 --- /dev/null +++ b/liby/Test2/Harness/Runner/Preload/Stage.pm @@ -0,0 +1,159 @@ +package Test2::Harness::Runner::Preload::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Test2::Harness::Util::HashBase qw{ + <name + <frame + <children + <pre_fork_callbacks + <post_fork_callbacks + <pre_launch_callbacks + <load_sequence + <watches + eager + reload_remove_check + reload_inplace_check +}; + +sub init { + my $self = shift; + + $self->{+FRAME} //= [caller(1)]; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; + croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; + + $self->{+CHILDREN} //= []; + + $self->{+PRE_FORK_CALLBACKS} //= []; + $self->{+POST_FORK_CALLBACKS} //= []; + $self->{+PRE_LAUNCH_CALLBACKS} //= []; + + $self->{+LOAD_SEQUENCE} //= []; + $self->{+WATCHES} //= {}; +} + +sub watch { + my $self = shift; + my ($file, $callback) = @_; + croak "The first argument must be a file" unless $file && -f $file; + croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; + croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; + + $self->{+WATCHES}->{$file} = $callback; + return; +} + +sub all_children { + my $self = shift; + + my @out = @{$self->{+CHILDREN}}; + + for (my $i = 0; $i < @out; $i++) { + my $it = $out[$i]; + push @out => @{$it->children}; + } + + return \@out; +} + +sub add_child { + my $self = shift; + my ($stage) = @_; + push @{$self->{+CHILDREN}} => $stage; +} + +sub add_pre_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; +} + +sub add_post_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+POST_FORK_CALLBACKS}} => $cb; +} + +sub add_pre_launch_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; +} + +sub add_to_load_sequence { + my $self = shift; + + for my $item (@_) { + croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" + unless ref($item) eq 'CODE' || !ref($item); + + push @{$self->{+LOAD_SEQUENCE}} => $item; + } + + return @_; +} + +sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } +sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } +sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preload::Stage - Abstraction of a preload stage. + +=head1 DESCRIPTION + +This is an implementation detail. You are not intended to directly use/modify +instances of this class. See L<Test2::Harness::Runner::Preload> for +documentation on how to write a custom preload library. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Preloader.pm b/liby/Test2/Harness/Runner/Preloader.pm new file mode 100644 index 000000000..5bce0871b --- /dev/null +++ b/liby/Test2/Harness/Runner/Preloader.pm @@ -0,0 +1,665 @@ +package Test2::Harness::Runner::Preloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use B(); +use Carp qw/confess croak/; +use Fcntl qw/LOCK_EX LOCK_UN/; +use Time::HiRes qw/time sleep/; +use Test2::Harness::Util qw/open_file file2mod mod2file lock_file unlock_file clean_path/; + +use Test2::Harness::Runner::Reloader; +use Test2::Harness::Runner::Preloader::Stage; + +use File::Spec(); +use List::Util qw/pairgrep/; + +use Test2::Harness::Util::HashBase( + qw{ + <dir + <preloads + <done + <below_threshold + + <dtrace <reloader + + <staged <started_stages <stage + + <dump_depmap + <changed + <restrict_reload + + <blacklist_file + <blacklist_lock + <blacklist + + <monitored + }, + + '<monitor', # This means watch for changes, restart stage if any found + '<reload', # Try to reload in place instead of restart stage +); + +sub init { + my $self = shift; + + $self->{+PRELOADS} //= []; + + $self->{+BELOW_THRESHOLD} //= 0; + + return if $self->{+BELOW_THRESHOLD}; + + $self->{+MONITOR} = 1 if $self->{+RELOAD}; + + my $need_depmap = $self->{+RELOAD} || $self->{+MONITOR} || $self->{+DUMP_DEPMAP}; + + if ($need_depmap) { + require Test2::Harness::Runner::DepTracer; + $self->{+DTRACE} //= Test2::Harness::Runner::DepTracer->new(); + } + + if ($self->{+MONITOR} || $self->{+RELOAD}) { + $self->{+BLACKLIST} //= {}; + $self->{+BLACKLIST_FILE} //= File::Spec->catfile($self->{+DIR}, 'BLACKLIST'); + } + + $self->{+RELOADER} = Test2::Harness::Runner::Reloader->new( + stat_min_gap => 2, + notify_cb => sub { $self->_reload_cb_notify(@_) }, + find_loaded_cb => sub { $self->_reload_cb_find_loaded(@_) }, + should_watch_cb => sub { $self->_reload_cb_should_watch(@_) }, + can_reload_cb => sub { $self->_reload_cb_can_reload(@_) }, + reload_cb => sub { $self->_reload_cb_reload(@_) }, + delete_symbol_cb => sub { $self->_reload_cb_delete_symbol(@_) }, + ); +} + +sub stage_check { + my $self = shift; + my ($stage) = @_; + + return 0 if $self->{+BELOW_THRESHOLD}; + + my $p = $self->{+STAGED} or return 0; + return 1 if $stage eq 'NOPRELOAD'; + return 1 if $p->stage_lookup->{$stage}; + return 0; +} + +sub task_stage { + my $self = shift; + my ($file, $wants) = @_; + + $wants //= ""; + + return 'default' if $self->{+BELOW_THRESHOLD}; + return 'default' unless $self->{+STAGED}; + + return $wants if $wants && $self->stage_check($wants); + + my $stage = $self->{+STAGED}->file_stage($file) // $self->{+STAGED}->default_stage; + + return $stage; +} + +sub preload { + my $self = shift; + + croak "Already preloaded" if $self->{+DONE}; + + return 'default' if $self->{+BELOW_THRESHOLD}; + + my $preloads = $self->{+PRELOADS} or return 'default'; + return 'default' unless @$preloads; + + require Test2::API; + Test2::API::test2_start_preload(); + + # Not loading blacklist yet because any preloads in this list need to + # happen regardless of the blacklist. + if ($self->{+MONITOR} || $self->{+DTRACE}) { + $self->_monitor_preload($preloads); + } + else { + $self->_preload($preloads); + } + + $self->{+DONE} = 1; +} + +sub preload_stages { + my $self = shift; + return 'default' unless $self->{+STAGED}; + return $self->_preload_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); +} + +sub _preload_stages { + my $self = shift; + my @stages = @_; + + my $name = 'base'; + my @procs; + + while (my $stage = shift @stages) { + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $proc = $self->launch_stage($stage); + + if ($proc) { + push @procs => $proc; + next; + } + + # We are in the stage now, reset these + if (ref $stage) { + $name = $stage->name; + @procs = (); + @stages = @{$stage->children}; + } + else { # NOPRELOAD + $name = $stage; + @procs = (); + @stages = (); + } + + $self->start_stage($stage); + } + + return($name, @procs); +} + +sub launch_stage { + my $self = shift; + my ($stage) = @_; + + $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; + + my $name = ref($stage) ? $stage->name : $stage; + + my $pid = fork(); + + return Test2::Harness::Runner::Preloader::Stage->new( + pid => $pid, + name => $name, + ) if $pid; + + $0 .= "-$name"; + $ENV{T2_HARNESS_STAGE} = $name; + + return; +} + +sub start_stage { + my $self = shift; + my ($stage) = @_; + + if ($self->{+STAGED}) { + if ($stage && !ref($stage)) { + $stage = $self->{+STAGED}->stage_lookup->{$stage}; + } + } + else { + $stage = undef; + } + + $self->{+STAGE} = $stage; + + $self->load_blacklist if $self->{+MONITOR}; + + # Localize these in case something we preload tries to modify them. + local $SIG{INT} = $SIG{INT}; + local $SIG{HUP} = $SIG{HUP}; + local $SIG{TERM} = $SIG{TERM}; + + my $preloads = $stage ? $stage->load_sequence : []; + + my $meth = $self->{+MONITOR} || $self->{+DTRACE} ? '_monitor_preload' : '_preload'; + + $self->$meth($preloads, $stage->watches) if $preloads && @$preloads; + + $self->_monitor() if $self->{+MONITOR}; +} + +sub get_stage_callback { + my $self = shift; + my ($name) = @_; + + my $stage = $self->{+STAGE} or return undef; + return undef unless ref $stage; + return $stage->$name; +} + +sub _monitor_preload { + my $self = shift; + my ($preloads, $watch) = @_; + + my $block = {%{$self->blacklist}}; + my $dtrace = $self->dtrace; + + $dtrace->start; + $self->_preload($preloads, $block, $dtrace->my_require); + $dtrace->add_callbacks(%$watch) if $watch; + $dtrace->stop; + + return; +} + +sub _preload { + my $self = shift; + my ($preloads, $block, $require_sub) = @_; + + $block //= {}; + + my %seen; + for my $mod (@$preloads) { + next if $seen{$mod}++; + + if (ref($mod) eq 'CODE') { + next if eval { $mod->($block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + next; + } + + next if $block && $block->{$mod}; + + next if eval { $self->_preload_module($mod, $block, $require_sub); 1 }; + $self->{+MONITOR} ? warn $@ : die $@; + } + + return; +} + +sub _preload_module { + my $self = shift; + my ($mod, $block, $require_sub) = @_; + + my $file = mod2file($mod); + + $require_sub ? $require_sub->($file) : require $file; + + return unless $mod->can('TEST2_HARNESS_PRELOAD'); + + die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; + + $self->{+STAGED} //= do { + require Test2::Harness::Runner::Preload; + Test2::Harness::Runner::Preload->new(); + }; + + $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); + + return; +} + +sub eager_stages { + my $self = shift; + + return unless $self->{+STAGED}; + return $self->{+STAGED}->eager_stages; +} + +sub load_blacklist { + my $self = shift; + + my $bfile = $self->{+BLACKLIST_FILE}; + my $blacklist = $self->{+BLACKLIST}; + + return unless -f $bfile; + + my $fh = open_file($bfile, '<'); + while(my $pkg = <$fh>) { + chomp($pkg); + $blacklist->{$pkg} = 1; + } +} + +sub _lock_blacklist { + my $self = shift; + + return $self->{+BLACKLIST_LOCK} if $self->{+BLACKLIST_LOCK}; + + my $bl = lock_file($self->{+BLACKLIST_FILE}, '>>'); + seek($bl,2,0); + + return $self->{+BLACKLIST_LOCK} = $bl; +} + +sub _unlock_blacklist { + my $self = shift; + + my $bl = delete $self->{+BLACKLIST_LOCK} or return; + + $bl->flush; + unlock_file($bl); + close($bl); + + return; +} + +sub _notify { + my $self = shift; + for my $msg (@_) { + print "$$ $0 - $msg\n"; + } +} + +sub _reload_cb_notify { + my $self = shift; + my ($type, $info) = @_; + + return $self->_notify("Runner detected a change in one or more preloaded modules...") + if $type eq 'changes_detected'; + + return $self->_notify("Runner detected changes in file '$info'...") + if $type eq 'file_changed'; + + return $self->_notify("Runner attempting to reload '$info->{file}' in place...") + if $type eq 'reload_inplace'; + + return $self->_notify( + "Runner failed to reload '$info->{file}' in place...", + map { split /\n/, $_ } grep { $_ } @{$info->{warnings} // []}, $info->{error}, + ) if $type eq 'reload_fail'; + + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Maxdepth = 2; + return $self->_notify("Runner notification $type: " . (ref($info) ? Data::Dumper::Dumper($info) : $info) . "..."); +} + +sub _reload_cb_find_loaded { keys %{$_[0]->dtrace->loaded} } + +sub _reload_cb_should_watch { + my $self = shift; + my ($reloader, $rel, $abs) = @_; + + my $dirs = $self->{+RESTRICT_RELOAD}; + return 1 unless $dirs && @$dirs; + + for my $dir (@$dirs) { + return 1 if 0 == index($abs, $dir); + } + + return 0; +} + +sub _reload_cb_can_reload { + my $self = shift; + my %params = @_; + + my $mod = $params{module}; + my $file = $params{file}; + + return (0, reason => 'File is a yath preload module') if $mod->can('TEST2_HARNESS_PRELOAD'); + + if (my $cb = $self->get_stage_callback('reload_inplace_check')) { + my ($res, %fields) = $cb->(module => $mod, file => $file); + return ($res, %fields) if defined $res; + } + + return (1) unless $mod->can('import'); + + return (0, reason => 'File is an importer') if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT"}; + return (0, reason => 'File is an importer') if @{"$mod\::EXPORT_OK"}; + } + + return (1); +} + +sub find_churn { + my $self = shift; + my ($file) = @_; + + # When a file is saved to disk it seems it can vanish temporarily. Use this loop to wait for it... + my ($fh, $ok, $error); + for (1 .. 50) { + local $@; + $ok = eval { $fh = open_file($file) }; + $error = "LOOP $_: $@"; + last if $ok; + sleep 0.2; + } + + die $error // "Unknown error opening file '$file'" unless $fh; + + my $active = 0; + my @out; + + my $line_no = 0; + while (my $line = <$fh>) { + $line_no++; + + if ($active) { + if ($line =~ m/^\s*#\s*HARNESS-CHURN-STOP\s*$/) { + push @{$out[-1]} => $line_no; + $active = 0; + next; + } + else { + $out[-1][-1] .= $line; + next; + } + } + + if ($line =~ m/^\s*#\s*HARNESS-CHURN-START\s*$/) { + $active = 1; + push @out => [$line_no, '']; + } + } + + return @out; +} + +sub _reload_cb_reload { + my $self = shift; + my %params = @_; + + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my $callbacks; + if (my $dtrace = $self->dtrace) { + $callbacks = $dtrace->callbacks; + } + $callbacks //= {}; + + if (my $cb = $callbacks->{$file} // $callbacks->{$rel}) { + $self->_notify("Changed file '$rel' has a reload callback, executing it instead of regular reloading..."); + my $ret = $cb->(); + return (1, callback_return => $ret); + } + + if (my @churn = $self->find_churn($file)) { + $self->_notify("Changed file '$rel' contains churn sections, running them instead of a full reload..."); + + for my $churn (@churn) { + my ($start, $code, $end) = @$churn; + my $sline = $start + 1; + if (eval "package $mod;\nuse strict;\nuse warnings;\nno warnings 'redefine';\n#line $sline $file\n$code\n ;1;") { + $self->_notify("Success reloading churn block ($file lines $start -> $end)"); + } + else { + $self->_notify("Error reloading churn block ($file lines $start -> $end): $@"); + } + } + + return (1); + } + + return (0, reason => 'reloading disabled') unless $self->{+RELOAD}; + + return undef; +} + +sub _reload_cb_delete_symbol { + my $self = shift; + my %params = @_; + + my $sym = $params{symbol}; + my $mod = $params{module}; + my $file = $params{file}; + + # Make sure the changed file and the file that defined the sub are the same. + my $cb = $self->get_stage_callback('reload_remove_check') or return 0; + my $sub = $mod->can($sym) or return 0; + my $cobj = B::svref_2object($sub) or return 0; + my $subfile = $cobj->FILE or return 0; + + my $res = $cb->( + mod => $mod, + sym => $sym, + sub => $sub, + from_file => -f $subfile ? clean_path($subfile) : $subfile, + reload_file => -f $file ? clean_path($file) : $file, + ); + + # 0 means do not skip, so if the cb returned true we do not skip + return 0 if $res; + return 1; +} + +sub _monitor { + my $self = shift; + + if ($self->{+MONITORED} && $self->{+MONITORED}->[0] == $$) { + die "Monitor already starated\n" . "\n=======\n$0\n" . Carp::longmess() . "\n=====\n" . $self->{+MONITORED}->[1] . "\n" . $self->{+MONITORED}->[2] . "\n=======\n"; + } + + $self->{+MONITORED} = [$$, $0, Carp::longmess()]; + + my $reloader = $self->{+RELOADER}; + $reloader->reset(); + $reloader->refresh(); + + return $self->{+MONITORED}; +} + +sub check { + my $self = shift; + my ($state) = @_; + + return 1 if $self->{+CHANGED}; + + return 0 unless $self->{+MONITOR}; + + my $dtrace = $self->dtrace; + $dtrace->start if $self->{+RELOAD}; + + my $results = $self->{+RELOADER}->reload_changes(); + + $dtrace->stop if $self->{+RELOAD}; + + my (@todo, @fails); + for my $item (values %$results) { + my $stage = $self->{+STAGE} ? $self->{+STAGE}->name : 'default'; + $state->reload($stage => $item); + my $rel = $item->{reloaded}; + + next if $rel; # Reload success + + if (defined $rel) { # Not reloaded, but no error + push @todo => $item; + next; + } + } + + unless (@todo) { + $self->{+RELOADER}->refresh(); + return 0; + } + + $self->{+CHANGED} = 1; + $self->_notify("blacklisting changed files and reloading stage..."); + + my $bl = $self->_lock_blacklist(); + + my $dep_map = $self->dtrace->dep_map; + + my %CNI = reverse pairgrep { $b } %INC; + + my %seen; + while (@todo) { + my $item = shift @todo; + my $ref = ref($item); + + my ($mod, $abs, $rel); + if ($ref eq 'HASH') { + ($mod, $abs, $rel) = @{$item}{qw/module file relative/}; + } + elsif ($ref eq 'ARRAY') { + ($mod, $abs) = @$item; + $rel = $CNI{$abs} || $abs; + } + else { + die "Invalid ref type: $ref"; + } + + next if $seen{$abs}++; + next if $mod->can('TEST2_HARNESS_PRELOAD'); + $self->_notify("Blacklisting $mod..."); + print $bl "$mod\n"; + my $next = $dep_map->{$abs} or next; + push @todo => @$next; + } + + $self->_unlock_blacklist(); + + return 1; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader - Preload logic. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries before running tests. This +entire module is considered an "Implementation Detail". Please do not rely on +it always staying the same, or even existing in the future. Do not use this +directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/liby/Test2/Harness/Runner/Preloader/Stage.pm b/liby/Test2/Harness/Runner/Preloader/Stage.pm new file mode 100644 index 000000000..3559eabad --- /dev/null +++ b/liby/Test2/Harness/Runner/Preloader/Stage.pm @@ -0,0 +1,62 @@ +package Test2::Harness::Runner::Preloader::Stage; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::IPC::Process'; +use Test2::Harness::Util::HashBase qw{ <name eager }; + +sub category { $_[0]->{+CATEGORY} //= 'stage' } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Preloader::Stage - Representation of a persistent stage process. + +=head1 DESCRIPTION + +This module is responsible for preloading libraries for a specific stage before +running tests. This entire module is considered an "Implementation Detail". +Please do not rely on it always staying the same, or even existing in the +future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Reloader.pm b/liby/Test2/Harness/Runner/Reloader.pm new file mode 100644 index 000000000..010a30727 --- /dev/null +++ b/liby/Test2/Harness/Runner/Reloader.pm @@ -0,0 +1,338 @@ +package Test2::Harness::Runner::Reloader; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/file2mod is_same_file/; + +use File::Spec(); + +BEGIN { + local $@; + my $inotify = eval { require Linux::Inotify2; 1 }; + if ($inotify) { + my $MASK = Linux::Inotify2::IN_MODIFY(); + $MASK |= Linux::Inotify2::IN_ATTRIB(); + $MASK |= Linux::Inotify2::IN_DELETE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + $MASK |= Linux::Inotify2::IN_MOVE_SELF(); + + *USE_INOTIFY = sub() { 1 }; + require constant; + constant->import(INOTIFY_MASK => $MASK); + } + else { + *USE_INOTIFY = sub() { 0 }; + *INOTIFY_MASK = sub() { 0 }; + } +} + +use Test2::Harness::Util::HashBase qw{ + <notify_cb <find_loaded_cb <should_watch_cb <can_reload_cb <reload_cb <delete_symbol_cb + <monitored <monitor_lookup + <watcher + <stat_min_gap <stat_last_checked + <pid +}; + +sub _pid_check { + my $self = shift; + + return 1 unless USE_INOTIFY; + + my $pid = $self->{+PID} //= $$; + + croak "PID has changed $$ vs $pid (Maybe you need to call reset()?)" + unless $$ == $pid; + + return 1; +} + +sub init { + my $self = shift; + $self->{+CAN_RELOAD_CB} //= $self->can('_can_reload'); + $self->{+FIND_LOADED_CB} //= $self->can('_find_loaded'); + $self->{+STAT_MIN_GAP} //= 2; + + $self->reset; +} + +sub reset { + my $self = shift; + delete $self->{+PID}; + $self->{+MONITORED} = {}; + $self->{+MONITOR_LOOKUP} = {}; + if (USE_INOTIFY) { + $self->{+WATCHER} = Linux::Inotify2->new; + $self->{+WATCHER}->blocking(0); + } else { + $self->{+WATCHER} = {}; + } + delete $self->{+STAT_LAST_CHECKED}; +} + +sub _find_loaded { keys %INC } + +sub refresh { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + my $cb = $self->{+FIND_LOADED_CB}; + for my $file ($self->$cb($monitored)) { + next if exists $monitored->{$file}; + $self->monitor($file); + } +} + +sub monitor { + my $self = shift; + my ($file) = @_; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + return if exists $monitored->{$file}; + + my $watch = $self->find_file_to_watch($file); + + return $monitored->{$file} = 0 unless $watch && -e $watch; + + if (my $should_watch_cb = $self->{+SHOULD_WATCH_CB}) { + return $monitored->{$file} = 0 unless $self->$should_watch_cb($file => $watch); + } + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($watch, INOTIFY_MASK()); + } + else { + my $stats = $self->{+WATCHER}; + $stats->{$watch} = $self->_get_file_times($watch); + } + + $self->{+MONITOR_LOOKUP}->{$watch} = $file; + $monitored->{$file} = $watch; + return $watch; +} + +sub find_file_to_watch { + my $self = shift; + my ($file) = @_; + + return $INC{$file} if $INC{$file} && -e $INC{$file}; + + for my $dir (@INC) { + next if ref($dir); + my $path = File::Spec->catfile($dir, $file); + return $path if -f $path; + } + + return $file if -e $file; +} + +sub _get_file_times { + my $self = shift; + my ($file) = @_; + my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); + return [$mtime, $ctime]; +} + +sub _get_changes { + my $self = shift; + + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + my @todo = $inotify->read or return; + return {map { ($_->fullname() => 1) } @todo}; + } + + # Do not hammer the disk getting stat + my $check_time = time; + my $gap = $self->{+STAT_MIN_GAP}; + my $last_checked = $self->{+STAT_LAST_CHECKED}; + return if $last_checked && $gap && $gap > ($check_time - $last_checked); + $last_checked = $check_time; + + my $found = 0; + my $changed = {}; + my $stats = $self->{+WATCHER}; + for my $file (keys %$stats) { + my $old_times = $stats->{$file}; + my $new_times = $self->_get_file_times($file); + + # Compare times + next if $old_times->[0] == $new_times->[0] && $old_times->[1] == $new_times->[1]; + + # Update in case we choose not to reload + $stats->{$file} = $new_times; + + $found++; + $changed->{$file} = 1; + } + + return unless $found; + return $changed; +} + +sub _can_reload { + my %params = @_; + + my $mod = $params{module}; + + return 1 unless $mod->can('import'); + + return 0 if $mod->can('IMPORTER_MENU'); + + { + no strict 'refs'; + return 0 if @{"$mod\::EXPORT"}; + return 0 if @{"$mod\::EXPORT_OK"}; + } + + return 1; +} + +sub reload_changes { + my $self = shift; + + $self->_pid_check(); + + my $monitored = $self->{+MONITORED}; + + $self->refresh(); + + my $changed = $self->_get_changes() or return; + + my $notify_cb = $self->{+NOTIFY_CB}; + + $notify_cb->(changes_detected => [keys %$changed]) if $notify_cb; + + my %out; + for my $file (sort keys %$changed) { + if (USE_INOTIFY) { + my $inotify = $self->{+WATCHER}; + $inotify->watch($file, INOTIFY_MASK()); + } + + $notify_cb->(file_changed => $file) if $notify_cb; + + my $rel = $self->{+MONITOR_LOOKUP}->{$file}; + my $mod = file2mod($rel); + my %params = (reloader => $self, file => $file, relative => $rel, module => $mod, notify_cb => $notify_cb); + + my ($status, %fields) = $self->_reload_file(%params); + + $out{$file} = { + file => $file, + relative => $rel, + module => $mod, + reloaded => $status, + %fields, + }; + } + + return \%out; +} + +sub _reload_file { + my $self = shift; + my %params = @_; + + if (my $reload_cb = $self->{+RELOAD_CB}) { + my ($status, %fields) = $reload_cb->(%params); + return ($status, %fields) if defined $status; + } + + if (my $can_reload_cb = $self->{+CAN_RELOAD_CB}) { + my ($can, %fields) = $can_reload_cb->(%params); + return ($can, %fields) unless $can; + } + + my $notify_cb = delete $params{notify_cb}; + $notify_cb->(reload_inplace => \%params) if $notify_cb; + + my $del_cb = $self->{+DELETE_SYMBOL_CB}; + my ($file, $rel, $mod) = @params{qw/file relative module/}; + + my @warnings; + my $ok = eval { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + + my $stash = do { no strict 'refs'; \%{"${mod}\::"} }; + for my $sym (keys %$stash) { + next if $sym =~ m/::$/; + + next if $del_cb && $del_cb->(%params, symbol => $sym, stash => $stash); + + delete $stash->{$sym}; + } + + delete $INC{$rel}; + local $.; + require $rel; + die "Reloading '$rel' loaded '$INC{$rel}' instead of '$file', \@INC must have been altered" + unless is_same_file($file, $INC{$rel}); + + 1; + }; + my $err = $@; + + return (1) if $ok && !@warnings; + + $notify_cb->(reload_fail => {%params, warnings => \@warnings, error => $err}) if $notify_cb; + + return (undef, error => $err, warnings => \@warnings); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Reloader - reload logic. + +=head1 DESCRIPTION + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/liby/Test2/Harness/Runner/Resource.pm b/liby/Test2/Harness/Runner/Resource.pm new file mode 100644 index 000000000..81455162a --- /dev/null +++ b/liby/Test2/Harness/Runner/Resource.pm @@ -0,0 +1,597 @@ +package Test2::Harness::Runner::Resource; +use strict; +use warnings; + +use Term::Table; +use Time::HiRes qw/time/; +use Test2::Util::Times qw/render_duration/; + +our $VERSION = '1.000152'; + +sub scope_global { 0 } +sub scope_host { 0 } +sub scope_run { 1 } + +sub setup {} + +sub new { + my $class = shift; + return bless({@_}, $class); +} + +sub tick { } + +sub refresh { } + +sub discharge { } + +sub sort_weight { + my $class = shift; + return 100 if $class->job_limiter; + return 50; +} + +sub job_limiter { 0 } + +sub job_limiter_max { } + +sub job_limiter_at_max { 0 } + +sub available { -1 } + +sub record { } + +sub assign { } + +sub release { } + +sub cleanup { } + +sub status_data {()} + +sub status_lines { + my $self = shift; + + my $data = $self->status_data || return; + return unless @$data; + + my $out = ""; + + for my $group (@$data) { + my $gout = "\n"; + $gout .= "**** $group->{title} ****\n\n" if defined $group->{title}; + + for my $table (@{$group->{tables} || []}) { + my $rows = $table->{rows}; + + if (my $format = $table->{format}) { + my $rows2 = []; + + for my $row (@$rows) { + my $row2 = []; + for (my $i = 0; $i < @$row; $i++) { + my $val = $row->[$i]; + my $fmt = $format->[$i]; + + $val = defined($val) ? render_duration($val) : '--' + if $fmt && $fmt eq 'duration'; + + push @$row2 => $val; + } + push @$rows2 => $row2; + } + + $rows = $rows2; + } + + next unless $rows && @$rows; + + my $tt = Term::Table->new( + header => $table->{header}, + rows => $rows, + + sanitize => 1, + collapse => 1, + auto_columns => 1, + + %{$table->{term_table_opts} || {}}, + ); + + $gout .= "** $table->{title} **\n" if defined $table->{title}; + $gout .= "$_\n" for $tt->render; + $gout .= "\n"; + } + + if ($group->{lines} && @{$group->{lines}}) { + $gout .= "$_\n" for @{$group->{lines}}; + $gout .= "\n"; + } + + $out .= $gout; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource - Base class for resource management classes + +=head1 DESCRIPTION + +Sometimes you have limited resources that must be shared/divided between tests +that run concurrently. Resource classes give you a way to leverage the IPC +system used by L<Test2::Harness> to manage resource assignment and recovery. + +=head1 SYNOPSIS + +Here is a resource class that simply assigns an integer to each test. It would +be possible to re-use integers, but since there are infinite integers this +example is kept simple and just always grabs the next one. + + package Test2::Harness::Runner::Resource::Foo; + use strict; + use warnings; + + use parent 'Test2::Harness::Runner::Resource'; + + sub setup { + my $class = shift; # NOT AN INSTANCE + ... + } + + sub available { + my $self = shift; + my ($task) = @_; + + # There are an infinite amount of integers, so we always return true + return 1; + } + + sub assign { + my $self = shift; + my ($task, $state) = @_; + + # Next ID, do not record the state change yet! + my $id = 1 + ($self->{ID} //= 0); + + print "ASSIGN: $id = $task->{job_id}\n"; + + # 'record' should get whatever we need to record the resource, whatever you + # pass in will become the argument to the record() sub below. This may be a + # scalar, a hash, an array, etc. It will be serialized to JSON before + # record() sees it. + $state->{record} = $id; + + # Pass the resource into the test, this can be done as envronment variables + # and/or arguments to the test (@ARGV). + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + + # The return is ignored. + return; + } + + sub record { + my $self = shift; + my ($job_id, $record_arg_from_assign) = @_; + + # The ID from $state->{record}->{$pkg} in assign. + my $id = $record_arg_from_assign; + + # Update our internal state to reflect the new ID. + $self->{ID} = $id; + + # Add a mapping of what job ID gets what integer ID. + $self->{ID_TO_JOB_ID}->{$id} = $job_id; + $self->{JOB_ID_TO_ID}->{$job_id} = $id; + + print "RECORD: $id = $job_id\n"; + + # The return is ignored + } + + sub tick { + my $self = shift; + + # This is called by only 1 process at a time and gives you a way to do + # extra stuff at a regular interval without other processes trying to + # do the same work at the same time. + # For example, if a database is left in a dirty state after it is + # released, you can fire off a cleanup action here knowing no other + # process will run it at the same time. You can also be sure no record + # messages will be sent while this sub is running as the process it + # runs in has a lock. + + ... + } + + + sub release { + my $self = shift; + my ($job_id) = @_; + + # Clear the internal mapping, the integer ID is now free. Theoretically it + # can be reused, but this example is not that complex. + my $id = delete $self->{JOB_ID_TO_ID}->{$job_id}; + + # This is called for all tests that complete, even if they did not use + # this resource, so we return if the job_id is not applicable. + return unless defined $id; + + delete $self->{ID_TO_JOB_ID}->{$id}; + + print " FREE: $id = $job_id\n"; + + # The return is ignored + } + + sub cleanup { + my $self = shift; + + print "CLEANUP!\n"; + } + + 1; + +The print statements generated will look like this when running 2 tests concurrently: + + yath test -R Foo -j2 t/testA.t t/testB.t + [...] + (INTERNAL) ASSIGN: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) RECORD: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) ASSIGN: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) RECORD: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) FREE: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 + (INTERNAL) FREE: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 + (INTERNAL) CLEANUP! + [...] + +Depending on the tests run the 'FREE' prints may be out of order. + +=head1 WORKFLOW + +=head2 HOW STATE IS MANAGED + +Depending on your preload configuration, yath may have several runners +launching tests. If a runner has nothing to do it will lock the queue and try +to find the next test that should be run. Only 1 of the runners will be in +control of the queue at any given time, but the control of the queue may pass +between runners. To manage this there is a mechanism to record messages that +allow each runner to maintain a copy of the current state. + +=head2 CHECK IF RESOURCES ARE AVAILABLE + +Each runner will have an instance of your resource class. When the runner is in +control of the queue, and wants to designate the next test to run, it will +check with the resource classes to make sure the correct resources are +available. To do that it will call C<available($task)> on each resource +instance. + +The C<$task> will contain the specification for the test, it is a hashref, and +you B<SHOULD NOT> modify it. The only key most people care about is the 'file' +key, which has the test file that will be run if resources are available. + +If resources are available, or if the specific file does not need the resource, +the C<available()> method should return true. If the file does need your +resource(s), and none are available, this should return false. If any resource +class returns false it means the test cannot be run yet and the runner will +look for another test to run. + +=head2 ASSIGN A RESOURCE + +If the runner has determined the test can be run, and all necessary resources +are available, it will then call C<assign($task, $state)> on all resource class +instances. At this time the resource class should decide what resource(s) to +assign to the class. + +B<CRITICAL NOTE:> the C<assing()> method B<MUST NOT> alter any internal state +on the resource class instance. State modification must wait for the +C<record()> method to be called. This is because the C<assign()> method is only +called in one runner process, the C<record()> method call will happen in every +runner process to insure they all have the same internal state. + +The assign() sub should modify the C<$state> hash, which has 3 keys: + +=over 4 + +=item env_vars => {} + +Env vars to set for the test + +=item args => [] + +Arguments to pass to the test + +=item record => ... + +Data needed to record the state change for resource classes. Can be a scalar, +hashref, arrayref, etc. It will be serialized to JSON to be passed between +processes. + +=back + +=head2 RECORD A RESOURCE + +Once a resource is assigned, a message will be sent to all runner processes +B<INCLUDING THE ONE THAT DID THE ASSIGN> that says it should call +C<record($job_id, $record_val)> on your resource class instance. Your resource +class instance must use this to update the state so that once done ALL +processes will have the proper internal state. + +The C<$record_val> is whatever you put into C<< $state->{record} >> in the +C<assign()> method above. + +=head2 QUEUE MANAGEMENT IS UNLOCKED + +Once the above has been done, queue management will be unlocked. You can be +guarenteed that only one process will be run the C<available()>, and +C<assign()> sequence at a time, and that they will be called in order, though +C<assign()> may not be called if another resource was not available. If +C<assign()> is called, you can be guarenteed that all processes, including the +one that called C<assign()> will have their C<record()> called with the proper +argument B<BEFORE> they try to manage the queue (which is the only place +resources are checked or assigned). + +=head2 RELEASE A RESOURCE + +Whenever a process that is using a resource exits, the runner that waits on +that process will I<eventually> send an IPC message announcing that the job_id +has completed. Every time a job_id completes the C<release($job_id)> method +will be called on your resource class in all runner processes. This allows the +state to be updated to reflect the freed resource. + +You can be guarenteed that any process that locks the queue to run a new +test will eventually see the message. The message may come in during a loop +that is checking for resources, in which case the state will not reflect the +resource being available, however in such cases the loop will end and be +called again later with the message having been receieved. There will be no +deadlock due to a queue manager waiting for the message. + +There are no guarentees about what order resources will be released in. + +=head1 METHODS + +=over 4 + +=item $class->setup($settings) + +This will be called once before the runner forks or initialized per-process +instances. If you have any "setup once" tasks to initialize resources before +tests run this is a good place to do it. + +This runs immedietly after plugin setup() methods are called. + +B<NOTE:> Do not rely on recording any global state here, the runner and +per-process instances may not be forked from the process that calls setup(). + +=item $res = $class->new(settings => $settings); + +A default new method, returns a blessed hashref with the settings key set to +the L<Test2::Harness::Settings> instance. + +=item $val = $res->available(\%task) + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +B<DO NOT MODIFY THE TASK HASHREF> + +Returns a positive true value if the resource is available. + +Returns false if the resource is not available, but will be in the future (IE +in use by another test, but will be free when that test is done). + +Returns a negative value if the resource is not available and never will be. +This will cause any tests dependent on the resource to be skipped. + +The only key in C<\%task> hashref that most resources will care about is the +C<'file'> key, which contains the test file to be run. + +=item $res->assign(\%task, \%state) + +B<DO NOT MODIFY THE TASK HASHREF> + +B<DO NOT MODIFY ANY INTERNAL STATE IN THIS METHOD> + +If the task does not need any resources you may simply return. + +If resources are needed you should deduce what resources to assign. + +You should put any data needed to update the internal state of your resource +instance in the C<< $state->{record} >> hash key. It B<WILL> be serialized to +JSON before being used as an argument to C<record()>. + + $state->{record} = $id; + +If you do not set the 'record' key, or set it to undef, then the C<record()> +method will not be called. + +If your tests need to know what resources to use, you may set environment +variables and/or command line arguments to pass into the test (C<@ARGV>). + + $state->{env_vars}->{FOO_ID} = $id; + push @{$state->{args}} => $id; + +The C<\%state> hashref is used only by your instance, you are free to fully +replace the 'env_vars' and 'args' keys. They will eventually be merged into a +master state along with those of other resources, but this ref is exclusive to +you in this method. + +=item $inst->record($job_id, $record_arg_from_assign) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called in all processes so that your instance can update any +internal state. + +The C<$job_id> variable contains the id for the job to which the resource was +assigned. You should use this to record any internal state. The $job_id will be +passed to C<release()> when the job completes and no longer needs the resource. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example creating a database should not be +done here, multiple processes will fight to do the create. The creation, if +necessary should be done in C<assign()> which will be called in only one +process. + +=item $inst->release($job_id) + +B<NOTE: THIS MAY BE CALLED IN MUTLIPLE PROCESSES CONCURRENTLY>. + +This will be called for every test job that completes, even if it did not use +this resource. If the job_id did not use the resource you may simply return, +otherwise update the internal state to reflect that the resource is no longer +in use. + +This is intended only for modifying internal state, you should not do anything +in this sub that will explode if it is also done in another process at the same +time with the same arguments. For example deleting a database should not be +done here, multiple processes will fight to do the delete. C<assign()> is the +only method that will be run in a single process, so if a database needs to be +cleaned before it can be used you should clean it there. Any final cleanup +should be done in C<cleanup()> which will only be called by one process at the +very end. + +=item $inst->cleanup() + +This will be called once by the parent runner process just before it exits. +This is your chance to do any final cleanup tasks such as deleting databases +that are no longer going to be used by tests as no more will be run. + +=item $inst->tick() + +This is called by only 1 process at a time and gives you a way to do extra +stuff at a regular interval without other processes trying to do the same work +at the same time. + +For example, if a database is left in a dirty state after it is released, you +can fire off a cleanup action here knowing no other process will run it at the +same time. You can also be sure no record messages will be sent while this sub +is running as the process it runs in has a lock. + +=item $inst->refresh() + +Called once before each resource-request loop. This is your chance to do things +between each set of requests for resources. + +=item $bool = $inst->job_limiter() + +True if your resource is intended as a job limiter (IE alternative to +specifying -jN at the command line). + +=item $int = $inst->job_limiter_max() + +Max number of jobs this will allow at the moment, if this resource is a job +limiter. + +=item $bool = $inst->job_limiter_at_max() + +True if the limiter has reached its maximum number of running jobs. This is +used to avoid a resource-allocation loop as an optimization. + +=item $number = $inst->sort_weight() + +Used to sort resources if you want them to be checked in a specific order. For +most resources this defaults to 50. For job_limiter resources this defaults to +100. Lower numbers are sorted to the front of the list, IE they are aquired +first, before other resources. + +Job slots are sorted later (100) so that we do not try to grab a job slot if +other resources are not available. + +Most of the time order will not matter, however with Shared job slots we have a +race with other test runs to get slots, and checking availability is enough to +consume a slot, even if other resources are not available. + +=item $string = $inst->status_lines() + +Get a (multi-line) string with status info for this resource. This is used to +populate the output for the C<yath resources> command. + +The default implementation will build a string from the data provided by the +C<status_data()> method. + +=item $arrayref = $inst->status_data() + +The default implementation returns an empty list. + +This should return status data that looks like this: + + return [ + { + title => "Resource Group Title", + tables => [ + { + header => \@columns, + rows => [ + \@row1, + \@row2, + ], + + # Optional fields + ################## + + # formatting for fields in rows + format => [undef, undef, 'duration', ...], + + # Title for the table + title => "Table Title", + + # Options to pass to Term::Table if/when it the data is used in Term::Table + term_table_opts => {...}, + }, + + # Any number of tables is ok + {...}, + ], + }, + + # Any number of groups is ok + {...}, + ]; + +Currently the only supported formats are 'default' (undef), and 'duration'. +Duration takes a stamp and tells you how much time has passed since the stamp. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Resource/JobCount.pm b/liby/Test2/Harness/Runner/Resource/JobCount.pm new file mode 100644 index 000000000..1c8fb3f6d --- /dev/null +++ b/liby/Test2/Harness/Runner/Resource/JobCount.pm @@ -0,0 +1,168 @@ +package Test2::Harness::Runner::Resource::JobCount; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw/<settings <job_count <used <free/; +use Time::HiRes qw/time/; +use List::Util qw/min/; + +sub job_limiter { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + $self->{+JOB_COUNT} //= $settings ? $settings->runner->job_count // 1 : 1; + $self->{+USED} //= {}; + $self->{+FREE} //= [1 .. $self->{+JOB_COUNT}]; +} + +sub job_limiter_max { + my $self = shift; + return $self->{+JOB_COUNT}; +} + +sub job_limiter_at_max { + my $self = shift; + return 0 if @{$self->{+FREE}}; + return 1; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + return -1 if $self->{+JOB_COUNT} < $tmin; + return -1 if $rmin < $tmin; + + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + return 1 if @{$self->{+FREE}} >= $concurrency; + return 0; +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + my $rmin = $self->settings->runner->slots_per_job; + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + my $concurrency = min(grep { $_ } $tmax, $rmin); + $concurrency ||= 1; + + $state->{record} = { + count => $concurrency, + file => $task->{rel_file}, + stamp => time, + }; + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $concurrency; +} + +sub record { + my $self = shift; + my ($job_id, $info) = @_; + + my $count = $info->{count}; + my @use = splice @{$self->{+FREE}}, 0, $count; + $info->{slots} = \@use; + + $self->{+USED}->{$job_id} = $info; +} + +sub release { + my $self = shift; + my ($job_id) = @_; + + # Could be a free with no used slot. + my $info = delete $self->{+USED}->{$job_id} or return; + my $slots = $info->{slots}; + + push @{$self->{+FREE}} => @$slots; +} + +sub status_data { + my $self = shift; + + my @rows; + + my $time = time; + + for my $info (sort { $a->{stamp} <=> $b->{stamp} } values %{$self->{+USED}}) { + my $count = @{$info->{slots} || []}; + push @rows => [$time - $info->{stamp}, $count, $info->{file}]; + } + + push @rows => [undef, scalar(@{$self->{+FREE}}), '** FREE **']; + + return [ + { + tables => [ + { + headers => [qw/Runtime Slots Name/], + format => ['duration'], + rows => \@rows, + }, + ], + }, + ], +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::JobCount - limit the job count (-j) + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Resource/SharedJobSlots.pm b/liby/Test2/Harness/Runner/Resource/SharedJobSlots.pm new file mode 100644 index 000000000..7651f90f2 --- /dev/null +++ b/liby/Test2/Harness/Runner/Resource/SharedJobSlots.pm @@ -0,0 +1,439 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Test2::Harness::Runner::Resource::SharedJobSlots::State; +use Test2::Harness::Runner::Resource::SharedJobSlots::Config; + +use Time::HiRes qw/time/; +use List::Util qw/min/; +use Carp qw/confess/; + +use parent 'Test2::Harness::Runner::Resource'; +use Test2::Harness::Util::HashBase qw{ + <settings + <state + <config + <runner_id + <runner_pid + <job_limiter_max + <observe +}; + +sub job_limiter { 1 } + +sub scope_host { 1 } + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + $self->init(); + return $self; +} + +sub init { + my $self = shift; + my $settings = $self->{+SETTINGS}; + + my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); + die "Could not find shared jobs config.\n" + unless $sconf; + + my $access_id = $self->{+RUNNER_ID} //= $settings->runner->runner_id if $settings->check_prefix('runner'); + my $access_pid = $self->{+RUNNER_PID} //= $Test2::Harness::Runner::RUNNER_PID // $App::Yath::Command::runner::RUNNER_PID; + + my $prefix = $settings->debug->procname_prefix // ''; + my $name = $settings->harness->project // ''; + + my $dir; + if (my $path = $settings->harness->config_file) { + if ($path =~ m{^(.*)/[^/]+$}) { + $dir = $1; + } + } + + $dir //= $settings->harness->cwd; + + unless ($name) { + $name = $dir; + $name =~ s{^.*/}{}; + } + + $name = "$prefix-$name" if $prefix; + + $self->{+JOB_LIMITER_MAX} = min(grep { $_ } $sconf->max_slots_per_run, $settings->runner->job_count); + + $self->{+STATE} = Test2::Harness::Runner::Resource::SharedJobSlots::State->new( + state_umask => $sconf->state_umask, + state_file => $sconf->state_file, + access_id => $access_id, + access_pid => $access_pid, + access_meta => { + dir => $dir, + name => $name, + runner_id => $access_id, + runner_pid => $access_pid, + }, + + algorithm => $sconf->algorithm, + max_slots => $sconf->max_slots, + max_slots_per_job => $sconf->max_slots_per_job, + max_slots_per_run => $sconf->max_slots_per_run, + min_slots_per_run => $sconf->min_slots_per_run, + default_slots_per_run => $sconf->default_slots_per_run, + default_slots_per_job => $sconf->default_slots_per_job, + + my_max_slots => min($self->settings->runner->job_count, $sconf->max_slots), + my_max_slots_per_job => min($self->settings->runner->slots_per_job, $sconf->max_slots_per_job), + ); + + $self->{+CONFIG} = $sconf; + + return; +} + +# Disable this short-circuit otherwise we may never queue a request! +sub job_limiter_at_max { 0 } + +sub refresh { $_[0]->{+STATE}->update_registration } + +sub _job_concurrency { + my $self = shift; + my ($task) = @_; + + my $rmax = $self->settings->runner->job_count; + my $jmax = $self->settings->runner->slots_per_job; + my $srmax = $self->{+CONFIG}->max_slots_per_run; + my $sjmax = $self->{+CONFIG}->max_slots_per_job; + + my $tmin = $task->{min_slots} // 1; + my $tmax = $task->{max_slots} // $tmin; + + my $max = min($tmax, $sjmax, $srmax, $jmax, $rmax); + + # Invalid condition, minimum is more than our maximim + return if $tmin > $max; + $max = $tmin if $max < $tmin; + + return [$tmin, $max]; +} + +sub available { + my $self = shift; + my ($task) = @_; + + my $con = $self->_job_concurrency($task); + return -1 unless $con; + + my $granted = $self->{+STATE}->allocate_slots(con => $con, job_id => $task->{job_id}); + + return unless $granted; + + return $granted +} + +sub assign { + my $self = shift; + my ($task, $state) = @_; + + return if $self->{+OBSERVE}; + + my $info = $self->{+STATE}->assign_slots( + job => { + job_id => $task->{job_id}, + file => $task->{rel_file} // $task->{file} // $task->{job_name}, + }, + ); + + $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $info->{count}; + + return $info; +} + +sub record { } # NOOP + +sub release { + my $self = shift; + my ($job_id) = @_; + + return if $self->{+OBSERVE}; + + $self->{+STATE}->release_slots(job_id => $job_id); + + return; +} + +sub status_data { + my $self = shift; + + my @groups; + + my $state = $self->state->state; + my $runners = $state->{runners}; + my $access = $state->{access}; + + my $global_status = { + todo => 0, + allotted => 0, + assigned => 0, + pending => 0, + }; + + my $time = time; + + for my $runner (sort { $a->{added} <=> $b->{added} } values %$runners) { + my $run_status = { + todo => $runner->{todo}, + allotted => $runner->{allotment}, + assigned => 0, + pending => 0, + }; + + my $job_table = { + header => [qw/Runtime Slots Name/], + format => ['duration', undef, undef], + rows => [], + }; + + for my $job (sort { $a->{started} <=> $b->{started} } values %{$runner->{assigned}}) { + $run_status->{assigned} += $job->{count}; + my $stamp = $job->{started}; + my $slots = $job->{count}; + + push @{$job_table->{rows}} => [$time - $stamp, $slots, $job->{file} // $job->{job_id}]; + } + + $run_status->{pending} = $runner->{allotment} - $run_status->{assigned}; + + $global_status->{$_} += $run_status->{$_} for keys %$global_status; + + my $run_table = { + header => [qw/Todo Allotted Assigned Pending/], + rows => [[$run_status->{todo}, $run_status->{allotted}, $run_status->{assigned}, $run_status->{pending}]], + }; + + my $acc = $access->{$runner->{runner_id}}; + push @groups => { + title => "$acc->{user} - $acc->{name} - $acc->{access_id}", + tables => [ + $run_table, + $job_table, + ], + }; + } + + $global_status->{total} = $self->state->{max_slots}; + $global_status->{free} = $global_status->{total} - ($global_status->{assigned} + $global_status->{pending}); + $global_status->{free} = "$global_status->{free} (Minimum per-run overrides max slot count in some cases)" if $global_status->{free} < 0; + + unshift @groups => { + title => 'System Wide Summary', + tables => [ + { + header => ['Todo', 'Total Shared Slots', 'Allotted Shared Slots', 'Assigned Shared Slots', 'Pending Shared Slots', 'Free Shared Slots'], + rows => [[ @{$global_status}{qw/todo total allotted assigned pending free/} ]], + } + ], + }; + + return \@groups; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots - limit the job count (-j) per machine + +=head1 SYNOPSIS + +B<This synopsis is not about using this in code, but rather how to use it on the command line.> + +In order to use SharedJobSlots you must ether create the C<.sharedjobslots.yml> +file, or provide the C<--shared-jobs-config PATH> argument on the command line. +The C<PATH> must be a path to a yaml file with configuration specifications for +job sharing. + +=head1 CONFIG FILE + +Config files for shared slots must be yaml file, they must also be parsable by +L<YAML::Tiny>, which implements a subset of yaml. + +Here is an example config file: + + --- + DEFAULT: + state_file: /tmp/yath-slot-state + max_slots: 8 + max_slots_per_job: 2 + max_slots_per_run: 6 + + myhostname: + state_file: /tmp/myhostname-slot-state + max_slots: 16 + max_slots_per_job: 4 + max_slots_per_run: 12 + +=head2 TOP LEVEL KEYS (HOSTNAMES) + +All top level keys are hostnames. When the config is read the settings for the +current hostname will be used. If the hostname is not defined then the +C<DEFAULT> host will be read. If there is no C<DEFAULT> host defined an +exception will be thrown. + +=head2 CONFIG OPTIONS + +Each option must be specified under a hostname, none of these are valid on +their own. + +=over 4 + +=item state_file: /path/to/shared/state/file + +B<REQUIRED> + +This specifies the path to the shared state file. All yath processes by all +users who are sharing slots need read+write access to this file. + +=item state_umask: 0007 + +Defaults to C<0007>. Used to set the umask of the state file as well as the +lock file. + +=item max_slots: 8 + +Max slots system-wide for all users to share. + +=item max_slots_per_run: 4 + +Max slots a specific test run can use. + +=item min_slots_per_run: 0 + +Minimum slots per run. + +Set this if you want to make sure that all runs get at least N slots, +B<EVEN IF IT MEANS GOING OVER THE SYSTEM-WIDE MAXIMUM!>. + +This defaults to 0. + +=item max_slots_per_job: 2 + +Max slots a specific test job (test file) can use. + +=item default_slots_per_run: 4 + +If the user does not specify a number of slots, use this as the default. + +=item default_slots_per_job: 2 + +If the user does not specify a number of job slots, use this as the default. + +=item algorithm: fair + +=item algorithm: first + +=item algorithm: Fully::Qualified::Module::function_name + +Algorithm to use when assigning slots. 'fair' is the default. + +=back + +=head3 ALGORITHMS + +These are algorithms that are used to decide which test runs get which slots. + +=over 4 + +=item fair + +B<DEFAULT> + +This algorithm tries to balance slots so that all runs share an equal fraction +of available slots. If there are not enough slots to go around then priority +goes to oldest runs, followed by oldest requests. + +=item first + +Priority goes to the oldest run, followed by the next oldest, etc. If the run +age is not sufficient to sort requests this will fall back to 'fair'. + +This is mainly useful for CI systems or batched test boxes. This will give +priority to the first test run started, so additional test runs will not +consume slots the first run wants to use, but if the first run is winding down +and does not need all the slots, the second test run can start using only the +spare slots. + +Use this with ordered test runs where you do not want a purely serial run +order. + +=item Fully::Qualified::Module::function_name + +You can specify custom algorithms by giving fully qualified subroutine names. + +=back + +Example custom algorithm: + + sub custom_sort { + my ($state_object, $state_data, $a, $b) = @_; + + return 1 if a_should_come_first($a, $b); + return -1 if b_should_come_first($a, $b); + return 0 if both_have_same_priority($a, $b); + + # *shrug* + return 0; + } + +Ultimately this is used in a C<sort()> call, usual rules apply, return should +be 1, 0, or -1. $a and $b are the 2 items being compared. $state_object is an +instance of C<Test2::Harness::Runner::Resource::SharedJobSlots::State>. +$state_data is a hashref like you get from C<< $state_object->state() >> which +is useful if you want to know how many slots each runner is using for a 'fair' +style algorth. + +Take a look at the C<request_sort_XXX> methods on +C<Test2::Harness::Runner::Resource::SharedJobSlots::State> which implement the +3 original sorting methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm b/liby/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm new file mode 100644 index 000000000..353c6761c --- /dev/null +++ b/liby/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm @@ -0,0 +1,178 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::Config; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use YAML::Tiny; +use Sys::Hostname qw/hostname/; +use App::Yath::Util qw/find_in_updir/; + +use Test2::Harness::Util::HashBase qw{ + <config_file + <config_raw + + <host + + <common_conf + <host_conf + + +state_file + +state_umask + +algorithm + +max_slots + +max_slots_per_job + +max_slots_per_run + +min_slots_per_run + +default_slots_per_job + +default_slots_per_run +}; + +sub find { + my $class = shift; + my (%opts) = @_; + + my $base_name = delete $opts{base_name}; + my $settings = delete $opts{settings}; + my $config_file = delete $opts{config_file}; + + unless ($config_file) { + $base_name //= ($settings && $settings->check_prefix('runner')) ? $settings->runner->shared_jobs_config : '.sharedjobslots.yml'; + $config_file = ($base_name =~ m{(/|\\)} || -e $base_name) ? $base_name : find_in_updir($base_name); + } + + return unless $config_file && -e $config_file; + + return $class->new(%opts, config_file => $config_file); +} + +sub init { + my $self = shift; + + my $config_file = $self->{+CONFIG_FILE}; + + my $config = YAML::Tiny->read($config_file) or die "Could not read '$config_file'"; + $config = $self->{+CONFIG_RAW} = $config->[0]; # First doc only + + my $host = $self->{+HOST} //= hostname(); + + # Normalize an empty host config section to a hashref + $config->{$host} ||= {} if exists $config->{$host}; + + unless ($self->{+HOST_CONF} = $config->{$host}) { + if ($self->{+HOST_CONF} = $config->{DEFAULT}) { + $self->{+HOST} = 'DEFAULT'; + } + else { + die "Could not find '$host' or 'DEFAULT' settings in '$config_file'.\n"; + } + + warn <<" EOT" unless $self->{+HOST_CONF}->{no_warning}; +Using the 'DEFAULT' shared-slots host config. +You may want to add the current host to the config file. +To silence this warning, set the 'no_warning' key to true in the DEFAULT host config. + Config File: $config_file +Current Host: $host + EOT + } + + if ($self->{+HOST_CONF}->{use_common} //= 1) { + $self->{+COMMON_CONF} = $config->{'COMMON'} // {}; + } + + $self->{+COMMON_CONF} //= {}; + + #sanity check + $self->max_slots; + + return; +} + +sub state_umask { $_[0]->{+STATE_UMASK} //= $_[0]->_get_config_option(+STATE_UMASK, default => 0007) } +sub state_file { $_[0]->{+STATE_FILE} //= $_[0]->_get_config_option(+STATE_FILE, require => 1) } +sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_get_config_option(+MAX_SLOTS, required => 1) } +sub min_slots_per_run { $_[0]->{+MIN_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MIN_SLOTS_PER_RUN, default => 0) } +sub max_slots_per_job { $_[0]->{+MAX_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_JOB, default => $_[0]->max_slots) } +sub max_slots_per_run { $_[0]->{+MAX_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_RUN, default => $_[0]->max_slots) } +sub default_slots_per_job { $_[0]->{+DEFAULT_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_JOB, default => $_[0]->max_slots_per_job) } +sub default_slots_per_run { $_[0]->{+DEFAULT_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_RUN, default => $_[0]->max_slots_per_run) } + +sub _get_config_option { + my $self = shift; + my ($field, %opts) = @_; + + my $val = $self->{+HOST_CONF}->{$field} // $self->{+COMMON_CONF}->{$field} // $opts{default}; + + die "'$field' not set in '$self->{+CONFIG_FILE}' for host '$self->{+HOST}' or under 'COMMON' config.\n" + if $opts{required} && !defined($val); + + return $val; +} + +sub algorithm { + my $self = shift; + + return $self->{+ALGORITHM} if $self->{+ALGORITHM}; + + my $algorithm = $self->_get_config_option(+ALGORITHM, default => 'fair'); + + if ($algorithm =~ m/^(.*)::([^:]+)$/) { + my ($mod, $sub) = ($1, $2); + require(mod2file($mod)); + } + else { + require Test2::Harness::Runner::Resource::SharedJobSlots::State; + + my $short = $algorithm; + $algorithm = "_redistribute_$algorithm"; + + die "'$short' is not a valid algorithm (in file '$self->{+CONFIG_FILE}' under host '$self->{+HOST}' key 'algorithm'). Must be 'fair', 'first', or a Fully::Qualified::Module::function_name." + unless Test2::Harness::Runner::Resource::SharedJobSlots::State->can($algorithm); + } + + return $self->{+ALGORITHM} = $algorithm; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::Config - Config for shared job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm b/liby/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm new file mode 100644 index 000000000..86646242f --- /dev/null +++ b/liby/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm @@ -0,0 +1,384 @@ +package Test2::Harness::Runner::Resource::SharedJobSlots::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Time::HiRes qw/time/; +use List::Util qw/min sum0 max/; +use Carp qw/croak/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase qw{ + <max_slots + <max_slots_per_job + <max_slots_per_run + <min_slots_per_run + <default_slots_per_job + <default_slots_per_run + + <my_max_slots + <my_max_slots_per_job + + <algorithm + + <ready_assignments +}; + +use constant RUNNERS => 'runners'; +use constant RUNNER_ID => 'access_id'; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'max_slots' is a required attribute" unless $self->{+MAX_SLOTS}; + croak "'max_slots_per_job' is a required attribute" unless $self->{+MAX_SLOTS_PER_JOB}; + croak "'max_slots_per_run' is a required attribute" unless $self->{+MAX_SLOTS_PER_RUN}; + + $self->{+MY_MAX_SLOTS} //= $self->{+MAX_SLOTS}; + $self->{+MY_MAX_SLOTS_PER_JOB} //= $self->{+MAX_SLOTS_PER_JOB}; + + $self->{+MIN_SLOTS_PER_RUN} //= 0; + + $self->{+ACCESS_META}->{name} //= $self->{+ACCESS_ID}; + + $self->{+ALGORITHM} //= '_redistribute_fair'; +} + +sub init_state { + my $self = shift; + my $state = $self->SUPER::init_state(); + $state->{+RUNNERS} = {}; + return $state; +} + +sub _clear_old_registrations { + my $self = shift; + my ($state) = @_; + + my $removed = $self->SUPER::_clear_old_registrations(@_); + + my $runners = $state->{+RUNNERS}; + delete $runners->{$_} for @$removed; + + return $removed; +} + +sub allocate_slots { + my $self = shift; + my (%params) = @_; + + my $con = $params{con} or croak "'con' is required"; + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_allocate_slots', con => $con, job_id => $job_id); +} + +sub assign_slots { + my $self = shift; + my (%params) = @_; + + my $job = $params{job} or croak "'job' is required"; + + return $self->transaction(rw => '_assign_slots', job => $job); +} + +sub release_slots { + my $self = shift; + my (%params) = @_; + + my $job_id = $params{job_id} or croak "'job_id' is required"; + + return $self->transaction(rw => '_release_slots', job_id => $job_id); +} + +sub _get_runner_entry { + my $self = shift; + my ($state, $runner_id) = @_; + + $runner_id //= $self->{+RUNNER_ID}; + + return $state->{+RUNNERS}->{$runner_id} //= { + runner_id => $runner_id, + added => time, + + todo => 0, + allocated => 0, + allotment => 0, + assigned => {}, + + max_slots => $self->{+MY_MAX_SLOTS}, + max_slots_per_job => $self->{+MY_MAX_SLOTS_PER_JOB}, + }; +} + +sub _allocate_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job_id = $params{job_id}; + my $con = $params{con}; + my ($min, $max) = @$con; + $self->_runner_todo($entry, $job_id => $max); + + my $allocated = $entry->{allocated} //= 0; + + # We have what we need already allocated + return $entry->{allocated} = $max + if $max <= $allocated; + + return $entry->{allocated} + if $entry->{allocated} >= $min; + + # Our allocation, if any, is not big enough, free it so we do not have a + # deadlock with all runner holding an insufficient allocation. + $allocated = $entry->{allocated} = 0; + + my $calcs = $self->_runner_calcs($entry); + + for (0 .. 1) { + $self->_redistribute($state) if $_; # Only run on second loop + + # Cannot do anything if we have no allotment or no available slots. + # This will go to the next loop for a redistribution, or end the loop. + my $allotment = $entry->{allotment} or next; + my $available = $allotment - $calcs->{assigned} or next; + + # If we get here we have an allotment (not 0) but it does not mean the + # minimum, so we have to skip the test. + return -1 if $allotment < $min; + + next unless $available >= $min; + + return $entry->{allocated} = min($available, $max); + } + + return 0; +} + +sub _assign_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + delete $entry->{_calc_cache}; + + my $job = $params{job}; + my $job_id = $job->{job_id}; + my $allocated = $entry->{allocated}; + + $self->_runner_todo($entry, $job_id => -1); + + $job->{count} = $allocated; + $job->{started} = time; + + $entry->{allocated} = 0; + + $entry->{assigned}->{$job->{job_id}} = $job; + + return $job; +} + +sub _release_slots { + my $self = shift; + my ($state, %params) = @_; + + my $entry = $self->_get_runner_entry($state); + + my $job_id = $params{job_id}; + + delete $entry->{assigned}->{$job_id}; + delete $entry->{_calc_cache}; + + $self->_runner_todo($entry, $job_id => -1); + + # Reduce our allotment if it makes sense to do so. + my $calcs = $self->_runner_calcs($entry); + $entry->{allotment} = $calcs->{total} if $entry->{allotment} > $calcs->{total}; +} + +sub _runner_todo { + my $sef = shift; + my ($entry, $job_id, $count) = @_; + + my $jobs = $entry->{jobs} //= {}; + + if ($count) { + if ($count < 0) { + $count = delete $jobs->{$job_id}; + } + else { + $jobs->{$job_id} = $count; + } + } + elsif ($job_id) { + $count = $jobs->{$job_id}; + } + + $entry->{todo} = sum0(values %$jobs); + + return $count; +} + +sub _runner_calcs { + my $self = shift; + my ($runner) = @_; + + return $runner->{_calc_cache} if $runner->{_calc_cache}; + + my $max = min(grep {$_} $self->{+MAX_SLOTS_PER_RUN}, $runner->{max_slots}); + my $assigned = sum0(map { $_->{count} } values %{$runner->{assigned} //= {}}); + my $active = $runner->{allocated} + $assigned; + my $total = $runner->{todo} + $active; + my $wants = ($total >= $max) ? max($max, $active) : max($total, $active); + + return $runner->{_calc_cache} = { + max => $max, + assigned => $assigned, + active => $active, + total => $total, + wants => $wants, + }; +} + +sub _redistribute { + my $self = shift; + my ($state) = @_; + + my $max_run = $self->{+MAX_SLOTS_PER_RUN}; + + my $wanted = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + $runner->{allotment} = $calcs->{wants}; + $wanted += $calcs->{wants}; + } + + # Everyone gets what they want! + my $max = $self->{+MAX_SLOTS}; + return if $wanted <= $max; + + my $meth = $self->{+ALGORITHM}; + + return $self->$meth($state); +} + +sub _redistribute_first { + my $self = shift; + my ($state) = @_; + + my $min = $self->{+MIN_SLOTS_PER_RUN}; + my $max = $self->{+MAX_SLOTS}; + + my $c = 0; + for my $runner (sort { $a->{added} <=> $b->{added} } values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + my $wants = $calcs->{wants}; + + if ($max >= $wants) { + $runner->{allotment} = $wants; + } + else { + $runner->{allotment} = max($max, $min, 0); + } + + $max -= $runner->{allotment}; + + $c++; + } + + return; +} + +sub _redistribute_fair { + my $self = shift; + my ($state) = @_; + + my $runs = scalar keys %{$state->{+RUNNERS}}; + + # Avoid a divide by 0 below. + return unless $runs; + + my $total = $self->{+MAX_SLOTS}; + my $min = $self->{+MIN_SLOTS_PER_RUN}; + + my $used = 0; + for my $runner (values %{$state->{+RUNNERS}}) { + my $calcs = $self->_runner_calcs($runner); + + # We never want less than the 'active' number + my $set = $calcs->{active}; + + # If min is greater than the active number and there are todo tests, we + # use the min instead. + $set = $min if $set < $min && $runner->{todo}; + + $runner->{allotment} = $set; + $used += $set; + } + + my $free = $total - $used; + return unless $free >= 1; + + # Is there a more efficient way to do this? Yikes! + my @runners = values %{$state->{+RUNNERS}}; + while ($free > 0) { + @runners = sort { $a->{allotment} <=> $b->{allotment} || $a->{added} <=> $b->{added} } + grep { my $c = $self->_runner_calcs($_); $c->{wants} > $_->{allotment} } + @runners; + + $free--; + $runners[0]->{allotment}++; + } + + return; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Resource::SharedJobSlots::State - shared state for job slots + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2022 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Run.pm b/liby/Test2/Harness/Runner/Run.pm new file mode 100644 index 000000000..f67ac8a1f --- /dev/null +++ b/liby/Test2/Harness/Runner/Run.pm @@ -0,0 +1,130 @@ +package Test2::Harness::Runner::Run; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use File::Spec(); + +use Test2::Harness::Util::File::JSONL; + +use parent 'Test2::Harness::Run'; +use Test2::Harness::Util::HashBase qw{ + <workdir + <state + <run_id + + +run_dir +}; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + croak "'workdir' is a required attribute" unless $self->{+WORKDIR}; + croak "'state' is a required attribute" unless $self->{+STATE}; + croak "'run_id' is a required attribute" unless $self->{+RUN_ID}; +} + +sub run_dir { $_[0]->{+RUN_DIR} //= $_[0]->SUPER::run_dir($_[0]->{+WORKDIR}) } + +sub jobs { + my $self = shift; + my $data = $self->state->data->queue->{$self->{+RUN_ID}} or return []; + return $data->{list}; +} + +sub add_job { + my $self = shift; + my ($job, $spawn_time) = @_; + + my $json_data = $job->TO_JSON(); + $json_data->{stamp} = $spawn_time; + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + my $jobs = $data->jobs->{$self->{+RUN_ID}} //= { + closed => 0, + list => [], + }; + + push @{$jobs->{list}} => $json_data, + }); + + return $json_data; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Run - Runner specific subclass of a test run. + +=head1 DESCRIPTION + +Runner subclass of L<Test2::Harness::Run> for use inside the runner. + +=head1 METHODS + +In addition to the methods provided by L<Test2::Harness::Run>, these are provided. + +=over 4 + +=item $dir = $run->workdir + +Runner directory. + +=item $dir = $run->run_dir + +Directory specific to this run. + +=item $path = $run->jobs_file + +Path to the C<jobs.jsonl> file. + +=item $fh = $run->jobs + +Filehandle to C<jobs.jsonl>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/Spawn.pm b/liby/Test2/Harness/Runner/Spawn.pm new file mode 100644 index 000000000..5bb3b83f3 --- /dev/null +++ b/liby/Test2/Harness/Runner/Spawn.pm @@ -0,0 +1,89 @@ +package Test2::Harness::Runner::Spawn; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Runner::Job'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + + $self->{+RUN} //= Test2::Harness::Runner::Spawn::Run->new(); +} + +sub out_file { sprintf('/proc/%i/fd/1', $_[0]->{+TASK}->{owner}) } +sub err_file { sprintf('/proc/%i/fd/2', $_[0]->{+TASK}->{owner}) } +sub in_file { undef } + +sub args { @{$_[0]->{+TASK}->{args} //= []} } + +sub job_dir { "" } +sub run_dir { "" } + +sub use_stream { 0 } +sub event_uuids { 0 } +sub mem_usage { 0 } +sub io_events { 0 } + +# These return lists +sub load_import { } +sub load { } + +package Test2::Harness::Runner::Spawn::Run; + +sub new { bless {}, shift }; + +sub env_vars { {} } + +sub AUTOLOAD { } + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::Spawn - Minimal job class used for spawning processes + +=head1 DESCRIPTION + +Do not use this directly... + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Runner/State.pm b/liby/Test2/Harness/Runner/State.pm new file mode 100644 index 000000000..163a6685d --- /dev/null +++ b/liby/Test2/Harness/Runner/State.pm @@ -0,0 +1,875 @@ +package Test2::Harness::Runner::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::State; + +use Test2::Harness::Settings; +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run; +use Test2::Harness::Util::Queue; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase( + # These are construction arguments + qw{ + <eager_stages + <state + <workdir + <preloader + <no_poll + <resources + job_count + +settings + }, + + qw{ + <dispatch_file + <queue_ended + + <pending_tasks <task_lookup + <pending_runs +run <stopped_runs + <pending_spawns + + <running + <running_categories + <running_durations + <running_conflicts + <running_tasks + + <stage_readiness + + <task_list + + <halted_runs + + <reload_state + + <observe + }, +); + +sub init { + my $self = shift; + + croak "You must specify a workdir or provide state" + unless $self->{+STATE} || defined $self->{+WORKDIR}; + + $self->{+WORKDIR} //= $self->{+STATE}->workdir; + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; + + if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { + my $settings = $self->settings; + my $resources = $self->{+RESOURCES} //= []; + for my $res (@{$self->settings->runner->resources}) { + require(mod2file($res)); + push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); + } + } + + unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { + require Test2::Harness::Runner::Resource::JobCount; + push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); + } + + @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; + + $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); + + $self->{+RELOAD_STATE} //= {}; + + $self->poll; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->state->settings; +} + +sub run { + my $self = shift; + return $self->{+RUN} if $self->{+RUN}; + $self->poll(); + return $self->{+RUN}; +} + +sub done { + my $self = shift; + + $self->poll(); + + return 0 if $self->{+RUNNING}; + return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; + + return 0 if $self->{+RUN}; + return 0 if @{$self->{+PENDING_RUNS} //= []}; + + return 0 unless $self->{+QUEUE_ENDED}; + + return 1; +} + +sub next_task { + my $self = shift; + my ($stage) = @_; + + $self->poll(); + $self->clear_finished_run(); + + while(1) { + if (@{$self->{+PENDING_SPAWNS} //= []}) { + my $spawn = shift @{$self->{+PENDING_SPAWNS}}; + next unless $spawn->{stage} eq $stage; + $self->start_spawn($spawn); + return $spawn; + } + + my $task = shift @{$self->{+TASK_LIST}} or return undef; + + # If we are replaying a state then the task may have already completed, + # so skip it if it is not in the running lookup. + next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; + next unless $task->{stage} eq $stage; + + return $task; + } +} + +sub advance { + my $self = shift; + $self->poll(); + + $_->tick() for @{$self->{+RESOURCES} //= []}; + + $self->advance_run(); + return 0 unless $self->{+RUN}; + return 1 if $self->advance_tasks(); + return $self->clear_finished_run(); +} + +my %ACTIONS = ( + queue_run => '_queue_run', + queue_task => '_queue_task', + queue_spawn => '_queue_spawn', + start_spawn => '_start_spawn', + start_run => '_start_run', + start_task => '_start_task', + stop_run => '_stop_run', + stop_task => '_stop_task', + retry_task => '_retry_task', + stage_ready => '_stage_ready', + stage_down => '_stage_down', + end_queue => '_end_queue', + halt_run => '_halt_run', + truncate => '_truncate', + reload => '_reload', +); + +sub poll { + my $self = shift; + + return if $self->{+NO_POLL}; + + my $queue = $self->dispatch_file; + + for my $item ($queue->poll) { + my $data = $item->[-1]; + my $item = $data->{item}; + my $action = $data->{action}; + my $pid = $data->{pid}; + + my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; + + $self->$sub($item, $pid); + } +} + +sub _enqueue { + my $self = shift; + my ($action, $item) = @_; + $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); + $self->poll; +} + +sub truncate { + my $self = shift; + $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; + $self->_enqueue(truncate => $$); + $self->poll; +} + +sub _truncate { } + +sub end_queue { $_[0]->_enqueue('end_queue' => 1) } +sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } + +sub halt_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(halt_run => $run_id); + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run_id}; + $data->jobs->{$run_id}->{closed} = 1; + }); +} + +sub _halt_run { + my $self = shift; + my ($run_id) = @_; + + delete $self->{+PENDING_TASKS}->{$run_id}; + + $self->{+HALTED_RUNS}->{$run_id}++; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + $self->_enqueue(queue_run => $run); +} + +sub _queue_run { + my $self = shift; + my ($run) = @_; + + push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( + %$run, + workdir => $self->{+WORKDIR}, + state => $self->{+STATE}, + ); + + return; +} + +sub start_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(start_run => $run_id); +} + +sub _start_run { + my $self = shift; + my ($run_id) = @_; + + my $run = shift @{$self->{+PENDING_RUNS}}; + die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; + die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; + + $self->{+RUN} = $run; + + return; +} + +sub stop_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(stop_run => $run_id); +} + +sub _stop_run { + my $self = shift; + my ($run_id) = @_; + + $self->{+STOPPED_RUNS}->{$run_id} = 1; + + return; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + $spawn->{spawn} //= 1; + $spawn->{id} //= gen_uuid(); + $self->_enqueue(queue_spawn => $spawn); +} + +sub _queue_spawn { + my $self = shift; + my ($spawn) = @_; + + $spawn->{id} //= gen_uuid(); + $spawn->{spawn} //= 1; + $spawn->{use_preload} //= 1; + + $spawn->{stage} //= 'default'; + $spawn->{stage} = $self->task_stage($spawn); + + push @{$self->{+PENDING_SPAWNS}} => $spawn; + + return; +} + +sub start_spawn { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_spawn => $spec); +} + +sub _start_spawn { + my $self = shift; + my ($spec) = @_; + + my $uuid = $spec->{id} or die "Could not find UUID for spawn"; + + @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; + + return; +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + $self->_enqueue(queue_task => $task); +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + my $job_id = $task->{job_id} or die "Task missing job_id"; + my $run_id = $task->{run_id} or die "Task missing run_id"; + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + +sub start_task { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_task => $spec); +} + +sub _start_task { + my $self = shift; + my ($spec) = @_; + + my $job_id = $spec->{job_id} or die "No job_id provided"; + my $run_stage = $spec->{stage} or die "No stage provided"; + my $res = $spec->{res} or die "No res provided"; + my $res_skip = $spec->{resource_skip}; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; + my $count = @$set; + @$set = grep { $_->{job_id} ne $job_id } @$set; + die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; + + $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); + + # Set the stage, new task hashref + $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; + + $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + push @{$task->{test_args}} => @{$res->{args}}; + + for my $resource (@{$self->{+RESOURCES}}) { + my $class = ref($resource); + my $val = $res->{record}->{$class} // next; + $resource->record($task->{job_id}, $val); + } + + die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; + $self->{+RUNNING_TASKS}->{$job_id} = $task; + + $task->{resource_skip} = $res_skip if $res_skip; + + push @{$self->{+TASK_LIST}} => $task; + + $self->{+RUNNING}++; + $self->{+RUNNING_CATEGORIES}->{$cat}++; + $self->{+RUNNING_DURATIONS}->{$dur}++; + + my $cfls = $task->{conflicts} //= []; + for my $cfl (@$cfls) { + die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" + if $self->{+RUNNING_CONFLICTS}->{$cfl}++; + } + + return; +} + +sub stop_task { + my $self = shift; + my ($job_id) = @_; + $self->_enqueue(stop_task => $job_id); +} + +sub _stop_task { + my $self = shift; + my ($job_id) = @_; + + my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; + + delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; + + $_->release($job_id) for @{$self->{+RESOURCES}}; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + $self->{+RUNNING}--; + $self->{+RUNNING_CATEGORIES}->{$cat}--; + $self->{+RUNNING_DURATIONS}->{$dur}--; + + my $cfls = $task->{conflicts} //= []; + $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; + + return; +} + +sub retry_task { + my $self = shift; + my ($job_id) = @_; + + $self->_enqueue(retry_task => $job_id); +} + +sub _retry_task { + my $self = shift; + my ($job_id) = @_; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; + + $self->_stop_task($job_id); + + return if $self->{+HALTED_RUNS}->{$task->{run_id}}; + + $task = {is_try => 0, %$task}; + $task->{is_try}++; + $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; + + $self->_queue_task($task); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_ready => $stage); +} + +sub _stage_ready { + my $self = shift; + my ($stage, $pid) = @_; + + $self->{+STAGE_READINESS}->{$stage} = $pid // 1; + + return; +} + +sub stage_down { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_down => $stage); +} + +sub _stage_down { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE_READINESS}->{$stage} = 0; + + return; +} + +sub reload { + my $self = shift; + my ($stage, $data) = @_; + $stage //= 'default'; + $self->_enqueue(reload => {%$data, stage => $stage}); + return; +} + +sub _reload { + my $self = shift; + my ($data) = @_; + + my $stage = $data->{stage}; + my $file = $data->{file}; + my $success = $data->{reloaded}; + my $error = $data->{error}; + my $warnings = $data->{warnings}; + + my $reload_state = $self->{+RELOAD_STATE} //= {}; + my $stage_state = $reload_state->{$stage} //= {}; + + # It either succeeded, or the stage will be reloaded, no need to track brokenness + if (defined $success) { + delete $stage_state->{$file}; + } + else { + my $fields = {}; + $fields->{error} = $error if defined($error) && length($error); + $fields->{warnings} = $warnings if $warnings && @{$warnings}; + + if (keys %$fields) { + $stage_state->{$file} = $fields; + } + else { + delete $stage_state->{$file}; + } + } + + return; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + return $wants if $self->{+NO_POLL}; + + return $wants // 'DEFAULT' unless $self->preloader; + return $self->preloader->task_stage($task->{file}, $wants); +} + +sub task_pending_lookup { + my $self = shift; + my ($task) = @_; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; +} + +sub task_fields { + my $self = shift; + my ($task) = @_; + + my $run_id = $task->{run_id} or die "No run id provided by task"; + my $smoke = $task->{smoke} ? 'smoke' : 'main'; + my $stage = $self->task_stage($task); + + my $cat = $task->{category}; + my $dur = $task->{duration}; + + die "Invalid category: $cat" unless CATEGORIES->{$cat}; + die "Invalid duration: $dur" unless DURATIONS->{$dur}; + + $cat = 'conflicts' if $cat eq 'general' && $task->{conflicts} && @{$task->{conflicts}}; + + return ($run_id, $smoke, $stage, $cat, $dur); +} + +sub prune_hash { + my $self = shift; + my ($hash, @path) = @_; + + die "No path!" unless @path; + + my $key = shift @path; + + if (@path) { + my $empty = $self->prune_hash($hash->{$key}, @path); + return 0 unless $empty; + } + + return 1 unless exists $hash->{$key}; + + my $ref = ref($hash->{$key}); + if ($ref eq 'HASH') { + return 0 if keys %{$hash->{$key}}; + } + elsif ($ref eq 'ARRAY') { + return 0 if @{$hash->{$key}}; + } + + delete $hash->{$key}; + return 1; +} + +sub advance_run { + my $self = shift; + + return 0 if $self->{+RUN}; + + return 0 unless @{$self->{+PENDING_RUNS} //= []}; + $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); + + return 1; +} + +sub clear_finished_run { + my $self = shift; + + my $run = $self->{+RUN} or return 0; + + return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; + return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; + return 0 if $self->{+RUNNING}; + + delete $self->{+RUN}; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run->run_id}; + $data->jobs->{$run->run_id}->{closed} = 1; + }); + + return 1; +} + +sub advance_tasks { + my $self = shift; + + for my $resource (@{$self->{+RESOURCES}}) { + $resource->refresh(); + + next unless $resource->job_limiter; + return 0 if $resource->job_limiter_at_max(); + } + + my ($run_stage, $task, $res, %params) = $self->_next(); + + my $out = 0; + if ($task) { + $out = 1; + $self->start_task({job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}); + } + + $_->discharge() for @{$self->{+RESOURCES}}; + + return $out; +} + +sub _cat_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; + + # Only search isolation if nothing is running. + push @cat_order => 'isolation' unless $self->{+RUNNING}; + + return \@cat_order; +} + +sub _dur_order { + my $self = shift; + + my $max = 0; + for my $resource (@{$self->resources}) { + next unless $resource->job_limiter; + my $val = $resource->job_limiter_max; + $max = $val if !$max || $val < $max; + } + $max //= 1; + + my $maxm1 = $max - 1; + + my $durs = $self->{+RUNNING_DURATIONS}; + + # 'short' is always ok. + my @dur_order = ('short'); + + # long and medium should be on the front of the search unless we are + # already running (max - 1) tests of the duration We want long first if + # we are not saturation on them, followed by medium, whcih is why they + # are listed in this order. + for my $c (qw/medium long/) { + if ($durs->{$c} && $durs->{$c} >= $maxm1) { + push @dur_order => $c; # Back of the list + } + else { + unshift @dur_order => $c; # Front of the list + } + } + + return \@dur_order; +} + +# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in +# which we search for tasks, 'RUN_STAGE' is the stage that actually does the +# work. This is what allows us to find tasks for 'eager' stages that are bored. +sub _stage_order { + my $self = shift; + + my $stage_check = $self->{+STAGE_READINESS} //= {}; + + my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; + + # Populate list with all ready stages + my %seen; + my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; + + # Add in any eager stages, but make sure they are last. + for my $rstage (@stage_list) { + next unless exists $self->{+EAGER_STAGES}->{$rstage}; + push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; + } + + return \@stages; +} + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::State - State tracking for the runner. + +=head1 DESCRIPTION + +This module tracks the state for all running tests. This entire module is +considered an "Implementation Detail". Please do not rely on it always staying +the same, or even existing in the future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Settings.pm b/liby/Test2/Harness/Settings.pm new file mode 100644 index 000000000..91a7b8e5c --- /dev/null +++ b/liby/Test2/Harness/Settings.pm @@ -0,0 +1,197 @@ +package Test2::Harness::Settings; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp(); +use Scalar::Util(); + +use Test2::Harness::Settings::Prefix; + +sub new { + my $class = shift; + + my $hash; + if (@_ == 1) { + require Test2::Harness::Util::File::JSON; + my $settings_file = Test2::Harness::Util::File::JSON->new(name => $_[0]); + $hash = $settings_file->read; + } + else { + $hash = {@_}; + } + + for my $key (keys %$hash) { + my $val = delete $hash->{$key}; + + if (Scalar::Util::blessed($val)) { + Carp::croak("All prefixes must contain instances of Test2::Harness::Settings::Prefix") + unless $val->isa('Test2::Harness::Settings::Prefix'); + + $hash->{$key} = $val; + next; + } + + Carp::croak("All prefixes must be defined as hashes") + unless ref($val) eq 'HASH'; + + $hash->{$key} = Test2::Harness::Settings::Prefix->new(%$val); + } + + return bless(\$hash, $class); +} + +sub define_prefix { + my $self = shift; + my ($prefix) = @_; + + return ${$self}->{$prefix} //= Test2::Harness::Settings::Prefix->new; +} + +sub check_prefix { + my $self = shift; + my ($prefix) = @_; + return exists(${$self}->{$prefix}); +} + +sub prefix { + my $self = shift; + my ($prefix, @args) = @_; + + Carp::croak("Too many arguments for prefix()") if @args; + Carp::croak("The '$prefix' prefix is not defined") unless ${$self}->{$prefix}; + + return ${$self}->{$prefix}; +} + +sub build { + my $self = shift; + my ($prefix, $class, @args) = @_; + + my $p = $self->prefix($prefix); + + $p->build($class, @args); +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $this = shift; + + my $prefix = $AUTOLOAD; + $prefix =~ s/^.*:://g; + + return if $prefix eq 'DESTROY'; + + Carp::croak("Method $prefix() must be called on a blessed instance") unless ref($this); + Carp::croak("Too many arguments for $prefix()") if @_; + + $this->prefix($prefix); +} + +sub TO_JSON { + my $self = shift; + return {%$$self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Settings - Configuration settings for Test2::Harness. + +=head1 DESCRIPTION + +This module represents the options provided at the command line. Each option +has a prefix, and each prefix can be accessed from the settings. + +=head1 SYNOPSIS + + # You will rarely if ever need to construct settings yourself, usually a + # component of Test2::Harness will expose them to you. + my $settings = $thing->settings; + + # All prefixes have a method generated for them via AUTOLOAD + my $display = $settings->display; + + # You can also use the prefix method + my $display = $settings->prefix('display'); + + + # The prefix can be used in a similar way + my $verbose = $settings->display->verbose; + +See L<Test2::Harness::Settings::Prefix> for more details on how to use the prefixes. + +=head1 METHODS + +Note that any prefix that does not conflict with the predefined methods can be +accessed via AUTOLOAD generating the methods as needed. + +=over 4 + +=item $settings->define_prefix($prefix_name) + +This is used to create a prefix. + +=item $bool = $settings->check_prefix($prefix_name) + +This is used to check if a prefix is defined or not. + +=item $prefix = $settings->prefix($prefix_name) + +=item $prefix = $settings->$prefix_name + +This will retrieve a prefix if it exists. If the prefix is not defined this +will throw an exception. If you are unsure if a prefix exists use +C<$settings->check_prefix($prefix_name)>. + +=item $thing = $settings->build($prefix_name, $class, @args) + +This will create an instance of C<$class> passing the key/value pairs from the +specified prefix as arguments. Additional arguments can be provided in +C<@args>. + +=item $hashref = $settings->TO_JSON() + +This method allows settings to be serialized into JSON. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Settings/Prefix.pm b/liby/Test2/Harness/Settings/Prefix.pm new file mode 100644 index 000000000..350f33c81 --- /dev/null +++ b/liby/Test2/Harness/Settings/Prefix.pm @@ -0,0 +1,188 @@ +package Test2::Harness::Settings::Prefix; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp(); +use Test2::Harness::Util(); + +sub new { + my $class = shift; + my $hash = {@_}; + return bless \$hash, $class; +} + +sub vivify_field { + my $self = shift; + my ($field) = @_; + + return \(${$self}->{$field}); +} + +sub check_field { + my $self = shift; + my ($field) = @_; + + return exists ${$self}->{$field}; +} + +sub field : lvalue { + my $self = shift; + my ($field, @args) = @_; + + Carp::croak("Too many arguments for field()") if @args > 1; + Carp::croak("The '$field' field does not exist") unless exists ${$self}->{$field}; + + (${$self}->{$field}) = @args if @args; + + return ${$self}->{$field}; +} + +sub remove_field { + my $self = shift; + my ($field) = @_; + delete ${$self}->{$field}; +} + +our $AUTOLOAD; +sub AUTOLOAD : lvalue { + my $this = shift; + + my $field = $AUTOLOAD; + $field =~ s/^.*:://g; + + return if $field eq 'DESTROY'; + + Carp::croak("Method $field() must be called on a blessed instance") unless ref($this); + Carp::croak("Too many arguments for $field()") if @_ > 1; + + $this->field($field, @_); +} + +sub TO_JSON { + my $self = shift; + return {%$$self}; +} + +sub build { + my $self = shift; + my ($class, @args) = @_; + + require(Test2::Harness::Util::mod2file($class)); + + return $class->new(%$$self, @args); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Settings::Prefix - Abstraction of a settings category, aka prefix. + +=head1 DESCRIPTION + +This class represents a settings category (prefix). + +=head1 SYNOPSIS + + # You will rarely if ever need to construct settings yourself, usually a + # component of Test2::Harness will expose them to you. + my $settings = $thing->settings; + my $display = $settings->display; + + # Once you have your prefix you can read data from it: + my $verbose = $display->verbose; + + # If you dislike autoload methods you can use the 'field' method: + my $verbose = $display->field('verbose'); + + # You can also change values: + $display->field(verbose => 1); + + # You can also use the autoloaded method as an lvalue, but this breaks on + # perls older than 5.16, so it is not used internally, and you should only + # use it if you know you will never need an older perl: + $display->verbose = 1; + +=head1 METHODS + +Note that any field that does not conflict with the predefined methods can be +accessed via AUTOLOAD generating the methods as needed. + +=over 4 + +=item $scalar_ref = $prefix->vivify_field($field_name) + +This will force a field into existance. It returns a scalar reference to the +field which can be used to set the value: + + my $vref = $display->vivify_field('verbose'); # Create or find field + ${$vref} = 1; # set verbosity to 1 + +=item $bool = $prefix->check_field($field_name) + +Check if a field is defined or not. + +=item $val = $prefix->field($field_name) + +=item $val = $prefix->$field_name + +=item $prefix->field($field_name, $val) + +=item $prefix->$field_name = $val + +Retrieve or set the value of the specified field. This will throw an exception +if the field does not exist. + +B<Note>: The lvalue form C<< $prefix->$field_name = $val >> breaks on perls +older then 5.16. + +=item $thing = $prefix->build($class, @args) + +This will create an instance of C<$class> passing the key/value pairs from the +prefix as arguments. Additional arguments can be provided in C<@args>. + +=item $hashref = $prefix->TO_JSON() + +This method allows settings to be serialized into JSON. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/State.pm b/liby/Test2/Harness/State.pm new file mode 100644 index 000000000..1367c57d7 --- /dev/null +++ b/liby/Test2/Harness/State.pm @@ -0,0 +1,302 @@ +package Test2::Harness::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use File::Spec; + +use Test2::Harness::State::Instance; +use Test2::Harness::Settings; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::Util qw/mod2file clean_path/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <workdir + + +resources +resource_list + +plugins +plugin_list +plugin_lookup + +renderer +renderer_list +renderer_lookup + +job_count + +settings + + <observe + }, +); + +sub state_class { 'Test2::Harness::State::Instance' } + +sub access_id { $_[0]->_access->[0] } +sub access_pid { $_[0]->_access->[1] } +sub registered { $_[0]->_access->[2] } + +sub _access { + my $self = shift; + + my $id = $self->{+ACCESS_ID}; + my $pid = $self->{+ACCESS_PID}; + + if (defined $pid) { + return [$id // $pid, $pid, $self->{+REGISTERED} ? 1 : 0] if $pid && $pid == $$; + } + + if(defined($id) || defined($pid)) { + delete $self->{+ACCESS_ID}; + delete $self->{+ACCESS_PID}; + } + + if (my $rpid = $self->{+REGISTERED}) { + delete $self->{+REGISTERED} unless $rpid == $$; + } + + return [$$, $$, $self->{+REGISTERED} ? 1 : 0]; +} + +sub init { + my $self = shift; + + my $workdir = $self->{+WORKDIR}; + my $state_file = $self->{+STATE_FILE}; + + if ($workdir) { + $state_file //= $self->{+STATE_FILE} //= File::Spec->catfile($workdir, 'state.json'); + } + elsif ($state_file) { + unless ($workdir) { + my $real_path = clean_path($state_file); # Follow symlinks, etc + my ($vol, $dir, $file) = File::Spec->splitpath($real_path); + $workdir = $self->{+WORKDIR} //= File::Spec->catpath($vol, $dir); + } + } + else { + croak "You must specify either a 'workdir' or a 'state_file'"; + } + + croak "Invalid work dir '$workdir'" unless -d $workdir; + + $self->{+STATE_FILE} = clean_path($state_file); + + $self->SUPER::init(); + + my @bad = grep { !$self->can(uc($_)) } keys %$self; + croak "The following invalid keys were passed into the constructor: " . join(', ' => @bad) + if @bad; + + $self->{+PLUGIN_LOOKUP} //= {}; +} + +sub sync_from_state { + my $self = shift; + my ($state) = @_; + + $self->SUPER::sync_from_state($state); + + $self->{+WORKDIR} = $state->{workdir}; +} + +sub init_state { + my $self = shift; + + confess "Attempt to initialize state from an observer" + if $self->{+OBSERVE}; + + my $state = $self->SUPER::init_state(); + + $state = $self->state_class->init_state($self, $state); + + return $state; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->transaction(r => sub { Test2::Harness::Settings->new(%{$_[1]->settings}) }); +} + +sub job_count { + my $self = shift; + return $self->{+JOB_COUNT} //= $self->transaction(r => sub { $_[1]->job_count }); +} + +sub _init_resources { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + my $has_limiter = undef; + + for my $res (@$list) { + my ($type, $inst); + if ($type = ref($res)) { + $inst = $res; + } + else { + $type = $res; + require(mod2file($res)); + $inst = $res->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + push @inst => $inst; + push @store => $type; + + $has_limiter ||= $inst->job_limiter; + } + + unless ($has_limiter) { + require Test2::Harness::Runner::Resource::JobCount; + push @store => 'Test2::Harness::Runner::Resource::JobCount'; + push @inst => Test2::Harness::Runner::Resource::JobCount->new(settings => $settings, observe => $self->{+OBSERVE}); + } + + return (\@store, \@inst); +} + +sub resource_list { + my $self = shift; + return $self->{+RESOURCE_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $list; + }); +} + +sub resources { + my $self = shift; + return $self->{+RESOURCES} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_resources($settings, $state->resources); + + $self->{+RESOURCE_LIST} = $list; + $self->{+RESOURCES} = $inst; + + return $inst; + }); +} + +sub _init_plugins { + my $self = shift; + my ($settings, $list) = @_; + + my (@store, @inst); + + for my $p (@$list) { + my ($type, $inst); + if ($type = ref($p)) { + $inst = $p; + } + else { + $type = $p; + require(mod2file($p)); + $inst = $p->new(settings => $settings) if $p->can('new'); + } + + push @store => $type; + push @inst => $inst; + } + + return (\@store, \@inst); +} + +sub plugin_list { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGIN_LIST} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $list; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "MODS-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +sub plugins { + my $self = shift; + my (@methods) = @_; + + my $plugins = $self->{+PLUGINS} // $self->transaction(r => sub { + my ($state) = @_; + my $settings = $self->settings; + my ($list, $inst) = $self->_init_plugins($settings, $state->plugins); + + $self->{+PLUGIN_LIST} = $list; + $self->{+PLUGINS} = $inst; + + return $inst; + }); + + return $plugins unless @methods; + + @methods = sort @methods; + my $key = "INST-" . join "|" => @methods; + return $self->{+PLUGIN_LOOKUP}->{$key} //= [ grep { my $p = $_; my $out = 1; $out &&= $p->can($_) for @methods; $out } @$plugins ]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State - State tracking for a yath instance + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/State/Instance.pm b/liby/Test2/Harness/State/Instance.pm new file mode 100644 index 000000000..2edca3303 --- /dev/null +++ b/liby/Test2/Harness/State/Instance.pm @@ -0,0 +1,111 @@ +package Test2::Harness::State::Instance; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/confess/; + +use parent 'Test2::Harness::IPC::SharedState'; +use Test2::Harness::Util::HashBase( + qw{ + <resources + <job_count + <settings + <workdir + <plugins + <runs + <ipc_model + <jobs + <queue + + <processes + <aggregators + }, +); + +sub init_state { + my $class = shift; + my ($state, $data) = @_; + + $data->{+WORKDIR} //= $state->{workdir} // confess "No workdir"; + $data->{+SETTINGS} //= $state->{settings} // confess "No settings"; + my $settings = $data->{settings}; + + $data->{+JOBS} //= {}; + $data->{+QUEUE} //= {}; + $data->{+IPC_MODEL} //= {}; + $data->{+JOB_COUNT} //= $state->{job_count} // $settings->check_prefix('runner') ? $settings->runner->job_count // 1 : 1; + + $data->{+PROCESSES} //= {}; + $data->{+AGGREGATORS} //= {}; + + for my $type (qw/resource plugin renderer/) { + my $plural = "${type}s"; + my $raw; + + if ($type eq 'resource') { + next unless $settings->check_prefix('runner'); + $raw = $settings->runner->$plural // []; + @$raw = sort { $a->sort_weight <=> $b->sort_weight } @$raw; + } + else { + next unless $settings->check_prefix('harness'); + next unless $settings->harness->check_field($plural); + $raw = $settings->harness->$plural // []; + } + + $data->{$plural} = [map { ref($_) || $_ } @$raw]; + } + + return bless($data, $class); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::State::Instance - Data structure for yath shared state + +=head1 DESCRIPTION + +This is the primary shared state for all processes participating in a yath +instance. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/TestFile.pm b/liby/Test2/Harness/TestFile.pm new file mode 100644 index 000000000..6381b1b79 --- /dev/null +++ b/liby/Test2/Harness/TestFile.pm @@ -0,0 +1,695 @@ +package Test2::Harness::TestFile; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use Time::HiRes qw/time/; + +use List::Util 1.45 qw/uniq/; + +use Test2::Harness::Util qw/open_file clean_path/; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use File::Spec; + +use Test2::Harness::Util::HashBase qw{ + <file +relative <_scanned <_headers +_shbang <is_binary <non_perl + input env_vars test_args + queue_args + job_class + comment + _category _stage _duration _min_slots _max_slots +}; + +sub set_duration { $_[0]->set__duration(lc($_[1])) } +sub set_category { $_[0]->set__category(lc($_[1])) } + +sub set_stage { $_[0]->set__stage($_[1]) } +sub set_min_slots { $_[0]->set__min_slots($_[1]) } +sub set_max_slots { $_[0]->set__max_slots($_[1]) } + +sub retry { $_[0]->headers->{retry} } +sub set_retry { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry} = $val; +} + +sub retry_isolated { $_[0]->headers->{retry_isolated} } +sub set_retry_isolated { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{retry_isolated} = $val; +} + +sub set_smoke { + my $self = shift; + my $val = @_ ? $_[0] : 1; + + $self->scan; + + $self->{+_HEADERS}->{features}->{smoke} = $val; +} + +sub init { + my $self = shift; + + my $file = $self->file; + + # We want absolute path + $file = clean_path($file, 0); + $self->{+FILE} = $file; + + $self->{+QUEUE_ARGS} ||= []; + + croak "Invalid test file '$file'" unless -f $file; + + if($self->{+IS_BINARY} = -B $file && !-z $file) { + $self->{+NON_PERL} = 1; + die "Cannot run binary test file '$file': file is not executable.\n" + unless $self->is_executable; + } +} + +sub relative { + my $self = shift; + return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE}); +} + +my %DEFAULTS = ( + timeout => 1, + fork => 1, + preload => 1, + stream => 1, + run => 1, + isolation => 0, + smoke => 0, + io_events => 1, +); + +sub check_feature { + my $self = shift; + my ($feature, $default) = @_; + + $default = $DEFAULTS{$feature} unless defined $default; + + return $default unless defined $self->headers->{features}->{$feature}; + return 1 if $self->headers->{features}->{$feature}; + return 0; +} + +sub check_stage { + my $self = shift; + + return $self->{+_STAGE} if $self->{+_STAGE}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{stage} || undef; +} + +sub check_min_slots { + my $self = shift; + + return $self->{+_MIN_SLOTS} if $self->{+_MIN_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{min_slots} // undef; +} + +sub check_max_slots { + my $self = shift; + + return $self->{+_MAX_SLOTS} if $self->{+_MAX_SLOTS}; + + $self->_scan unless $self->{+_SCANNED}; + return $self->{+_HEADERS}->{max_slots} // undef; +} + +sub meta { + my $self = shift; + my ($key) = @_; + + $self->_scan unless $self->{+_SCANNED}; + my $meta = $self->{+_HEADERS}->{meta} or return (); + + return () unless $key && $meta->{$key}; + + return @{$meta->{$key}}; +} + +sub check_duration { + my $self = shift; + + return $self->{+_DURATION} if $self->{+_DURATION}; + + $self->_scan unless $self->{+_SCANNED}; + my $duration = $self->{+_HEADERS}->{duration}; + return $duration if $duration; + + my $timeout = $self->check_feature(timeout => 1); + + # 'long' for anything with no timeout + return 'long' unless $timeout; + + return 'medium'; +} + +sub check_category { + my $self = shift; + + return $self->{+_CATEGORY} if $self->{+_CATEGORY}; + + $self->_scan unless $self->{+_SCANNED}; + my $category = $self->{+_HEADERS}->{category}; + + return $category if $category; + + my $isolate = $self->check_feature(isolation => 0); + + # 'isolation' queue if isolation requested + return 'isolation' if $isolate; + + return 'general'; +} + +sub event_timeout { $_[0]->headers->{timeout}->{event} } +sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} } + +sub conflicts_list { + return $_[0]->headers->{conflicts} || []; # Assure conflicts is always an array ref. +} + +sub headers { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_HEADERS}; + return {%{$self->{+_HEADERS}}}; +} + +sub shbang { + my $self = shift; + $self->_scan unless $self->{+_SCANNED}; + return {} unless $self->{+_SHBANG}; + return {%{$self->{+_SHBANG}}}; +} + +sub switches { + my $self = shift; + + my $shbang = $self->shbang or return []; + my $switches = $shbang->{switches} or return []; + + return $switches; +} + +sub is_executable { + my $self = shift; + my ($file) = @_; + $file //= $self->{+FILE}; + return -x $file; +} + +sub scan { + my $self = shift; + $self->_scan(); + return; +} + +sub _scan { + my $self = shift; + + return if $self->{+_SCANNED}++; + return if $self->{+IS_BINARY}; + + my $fh = open_file($self->{+FILE}); + my $comment = $self->{+COMMENT} // '#'; + + my %headers; + for (my $ln = 1; my $line = <$fh>; $ln++) { + chomp($line); + next if $line =~ m/^\s*$/; + + if ($ln == 1 && $line =~ m/^#!/) { + my $shbang = $self->_parse_shbang($line); + if ($shbang) { + $self->{+_SHBANG} = $shbang; + + if ($shbang->{non_perl}) { + $self->{+NON_PERL} = 1; + + die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n" + unless $self->is_executable; + } + + next; + } + } + + # Uhg, breaking encapsulation between yath and the harness + if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) { + $headers{features}->{run} = 0; + next; + } + + next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/; # Ignore commented lines which aren't HARNESS-? + next if $line =~ m/^\s*(use|require|BEGIN|package)\b/; # Only supports single line BEGINs + last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/; + + my ($dir, $rest) = split /[-\s]+/, $1, 2; + $dir = lc($dir); + my @args; + if ($dir eq 'meta') { + @args = split /\s+/, $rest, 2; # Check for white space delimited + @args = split(/[-]+/, $rest, 2) if scalar @args == 1; # Check for dash delimited + $args[1] =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + } + elsif ($rest) { + $rest =~ s/\s+(?:#.*)?$//; # Strip trailing white space and comment if present + @args = split /[-\s]+/, $rest; + } + + if ($dir eq 'no') { + my $feature = lc(join '_' => @args); + if ($feature eq 'retry') { + $headers{retry} = 0 + } else { + $headers{features}->{$feature} = 0; + } + } + elsif ($dir eq 'smoke') { + $headers{features}->{smoke} = 1; + } + elsif ($dir eq 'retry') { + $headers{retry} = 1 unless @args || defined $headers{retry}; + for my $arg (@args) { + if ($arg =~ m/^\d+$/) { + $headers{retry} = int $arg; + } + elsif ($arg =~ m/^iso/i) { + $headers{retry} //= 1; + $headers{retry_isolated} = 1; + } + else { + warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n"; + } + } + } + elsif ($dir eq 'yes' || $dir eq 'use') { + my $feature = lc(join '_' => @args); + $headers{features}->{$feature} = 1; + } + elsif ($dir eq 'stage') { + my ($name) = @args; + $headers{stage} = $name; + } + elsif ($dir eq 'meta') { + my ($key, $val) = @args; + $key = lc($key); + push @{$headers{meta}->{$key}} => $val; + } + elsif ($dir eq 'duration' || $dir eq 'dur') { + my ($name) = @args; + $name = lc($name); + $headers{duration} = $name; + } + elsif ($dir eq 'category' || $dir eq 'cat') { + my ($name) = @args; + $name = lc($name); + if ($name =~ m/^(long|medium|short)$/i) { + $headers{duration} = $name; + } + else { + $headers{category} = $name; + } + } + elsif ($dir eq 'conflicts') { + my @conflicts_array; + + foreach my $arg (@args) { + push @conflicts_array, lc($arg); + } + + # Allow multiple lines with # HARNESS-CONFLICTS FOO + $headers{conflicts} ||= []; + push @{$headers{conflicts}}, @conflicts_array; + + # Make sure no more than 1 conflict is ever present. + @{$headers{conflicts}} = uniq @{$headers{conflicts}}; + } + elsif ($dir eq 'timeout') { + my ($type, $num, $extra) = @args; + $type = lc($type); + $num = lc($num); + + ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit'; + + warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n" + unless $type =~ m/^(event|postexit)$/; + + $headers{timeout}->{$type} = $num; + } + elsif ($dir eq 'job' && $rest =~ m/slots\s+(\d+)(?:\s+(\d+))?$/i) { + $headers{min_slots} //= $1; + $headers{max_slots} //= $2 ? $2 : $1; + } + else { + warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n"; + } + } + + $self->{+_HEADERS} = \%headers; +} + +sub _parse_shbang { + my $self = shift; + my $line = shift; + + return {} if !defined $line; + + my %shbang; + + # NOTE: Test this, the dashes should be included with the switches + my $shbang_re = qr{ + ^ + \#!.*perl.*? # the perl path + (?: \s (-.+) )? # the switches, maybe + \s* + $ + }xi; + + if ($line =~ $shbang_re) { + my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1; + $shbang{switches} = \@switches; + $shbang{line} = $line; + } + elsif ($line =~ m/^#!/ && $line !~ m/perl/i) { + $shbang{line} = $line; + $shbang{non_perl} = 1; + } + + return \%shbang; +} + +sub queue_item { + my $self = shift; + my ($job_name, $run_id, %inject) = @_; + + die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n" + unless $self->check_feature(run => 1); + + my $category = $self->check_category; + my $duration = $self->check_duration; + my $stage = $self->check_stage; + my $min_slots = $self->check_min_slots; + my $max_slots = $self->check_max_slots; + + my $smoke = $self->check_feature(smoke => 0); + my $fork = $self->check_feature(fork => 1); + my $preload = $self->check_feature(preload => 1); + my $timeout = $self->check_feature(timeout => 1); + my $stream = $self->check_feature(stream => 1); + my $io_events = $self->check_feature(io_events => 1); + + my $retry = $self->retry; + my $retry_isolated = $self->retry_isolated; + + my $binary = $self->{+IS_BINARY} ? 1 : 0; + my $non_perl = $self->{+NON_PERL} ? 1 : 0; + + my $et = $self->event_timeout; + my $pet = $self->post_exit_timeout; + + my $job_class = $self->job_class; + + my $input = $self->input; + my $test_args = $self->test_args; + + my $env_vars = $self->env_vars; + if ($env_vars) { + my $mix = delete $inject{env_vars}; + $env_vars = {%$mix, %$env_vars} if $mix; + } + + return { + binary => $binary, + category => $category, + conflicts => $self->conflicts_list, + duration => $duration, + file => $self->file, + rel_file => $self->relative, + job_id => gen_uuid(), + job_name => $job_name, + run_id => $run_id, + non_perl => $non_perl, + stage => $stage, + stamp => time, + switches => $self->switches, + use_fork => $fork, + use_preload => $preload, + use_stream => $stream, + use_timeout => $timeout, + smoke => $smoke, + io_events => $io_events, + rank => $self->rank, + + defined($input) ? (input => $input) : (), + defined($env_vars) ? (env_vars => $env_vars) : (), + defined($test_args) ? (test_args => $test_args) : (), + defined($job_class) ? (job_class => $job_class) : (), + defined($retry) ? (retry => $retry) : (), + defined($retry_isolated) ? (retry_isolated => $retry_isolated) : (), + defined($et) ? (event_timeout => $et) : (), + defined($pet) ? (post_exit_timeout => $self->post_exit_timeout) : (), + defined($min_slots) ? (min_slots => $min_slots) : (), + defined($max_slots) ? (max_slots => $max_slots) : (), + + @{$self->{+QUEUE_ARGS}}, + + %inject, + }; +} + +my %RANK = ( + smoke => 1, + immiscible => 10, + long => 20, + medium => 50, + short => 80, + isolation => 100, +); + +sub rank { + my $self = shift; + + return $RANK{smoke} if $self->check_feature('smoke'); + + my $rank = $RANK{$self->check_category}; + $rank ||= $RANK{$self->check_duration}; + $rank ||= 1; + + return $rank; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::TestFile - Abstraction of a test file and its meta-data. + +=head1 DESCRIPTION + +When Test2::Harness finds test files to run each one gets an instance of this +class to represent it. This class will scan test files to find important meta +data (binary vs script, inline harness directives, etc). The meta-data this +class can find helps yath decide when and how to run the test. + +If you write a custom L<Test2::Harness::Finder> or use some +L<Test2::Harness::Plugin> callbacks you may have to use, or even construct +instances of this class. + +=head1 SYNOPSIS + + use Test2::Harness::TestFile; + + my $tf = Test2::Harness::TestFile->new(file => "path/to/file.t"); + + # For an example 1, 1 works, but normally they are job_name and run_id. + my $meta_data = $tf->queue_item(1, 1); + + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $tf->file + +Set during object construction, and cannot be changed. + +=item $bool = $tf->is_binary + +Automatically set during construction, cannot be changed or set manually. + +=item $bool = $tf->non_perl + +Automatically set during construction, cannot be changed or set manually. + +=item $string = $tf->comment + +=item $tf->set_comment($string) + +Defaults to '#' can be set during construction, or changed if needed. + +This is used to tell yath what character(s) are used to denote a comment. This +is necessary for finding harness directives. In perl the '#' character is used, +and that is the default value. This is here to support non-perl tests. + +=item $class = $tf->job_class + +=item $tf->set_job_class($class) + +Default it undef (let the runner pick). You can change this if you want the +test to run with a custom job subclass. + +=item $arrayref = $tf->queue_args + +=item $tf->set_queue_args(\@ARGS) + +Key/Value pairs to append to the queue_item() data. + +=back + +=head1 METHODS + +=over 4 + +=item $cat = $tf->check_category() + +=item $tf->set_category($cat) + +This is how you find the category for a file. You can use C<set_category()> to +assign/override a category. + +=item $dur = $tf->check_duration() + +=item $tf->set_duration($dur) + +Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override +with C<set_duration()>. + +=item $stage = $tf->check_stage() + +=item $tf->set_stage($stage) + +Get the preload stage the test file thinks it should be run in. You can +override with C<set_stage()>. + +=item $bool = $tf->check_feature($name) + +This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or +C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES> +and C<USE> will result in a ture boolean. If no directive is found then +C<undef> will be returned. + +=item $arrayref = $tf->conflicts_list() + +Get a list of conflict markers. + +=item $seconds = $tf->event_timeout() + +If they test specifies an event timeout this will return it. + +=item %headers = $tf->headers() + +This returns the header data from the test file. + +=item $bool = $tf->is_executable() + +Check if the test file is executable or not. + +=item $data = $tf->meta($key) + +Get the meta-data for the specific key. + +=item $seconds = $tf->post_exit_timeout() + +If the test file has a custom post-exit timeout, this will return it. + +=item $hashref = $tf->queue_item($job_name, $run_id) + +This returns the data used to add the test file to the runner queue. + +=item $int = $tf->rank() + +Returns an integer value used to sort tests into an efficient run order. + +=item $path = $tf->relative() + +Relative path to the test file. + +=item $tf->scan() + +Scan the file and populate the header data. Return nothing, takes no arguments. +Automatically run by things that require the scan data. Results are cached. + +=item $tf->set_smoke($bool) + +Set smoke status. Smoke tests go to the front of the line when tests are +sorted. + +=item $hashref = $tf->shbang() + +Get data gathered from parsing the tests shbang line. + +=item $arrayref = $tf->switches() + +A list of switches passed to perl, usually from the shbang line. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util.pm b/liby/Test2/Harness/Util.pm new file mode 100644 index 000000000..362c6871b --- /dev/null +++ b/liby/Test2/Harness/Util.pm @@ -0,0 +1,650 @@ +package Test2::Harness::Util; +use strict; +use warnings; + +use Carp qw/confess/; +use Cwd qw/realpath/; +use List::Util qw/min/; +use Test2::Util qw/try_sig_mask do_rename/; +use Fcntl qw/LOCK_EX LOCK_UN SEEK_SET :mode/; +use File::Spec; + +use List::Util qw/zip/; +use Config qw/%Config/; + +my @SIGNUMS = split(' ', $Config{sig_num}); +my @SIGNAMES = split(' ', $Config{sig_name}); + +my %SIG_NUM_LOOKUP = map { @$_ } zip(\@SIGNAMES, \@SIGNUMS); +my %SIG_NAME_LOOKUP = map { @$_ } zip(\@SIGNUMS, \@SIGNAMES); + +our $VERSION = '1.000152'; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + find_libraries + clean_path + + sig_name_to_num + sig_num_to_name + parse_exit + mod2file + file2mod + fqmod + + maybe_open_file + maybe_read_file + open_file + read_file + write_file + write_file_atomic + lock_file + unlock_file + + hub_truth + + apply_encoding + + process_includes + + chmod_tmp + + looks_like_uuid + is_same_file + + resize_pipe +}; + +sub resize_pipe { + return unless defined &Fcntl::F_SETPIPE_SZ; + my ($fh, $size) = @_; + + # 1mb if we can + $size //= 1024 * 1024 * 1; + + # On linux systems lets go for the smaller of the two between 1mb and + # system max. + if (-e '/proc/sys/fs/pipe-max-size') { + open(my $max, '<', '/proc/sys/fs/pipe-max-size'); + chomp(my $val = <$max>); + close($max); + $size = min($size, $val); + } + + fcntl($fh, Fcntl::F_SETPIPE_SZ(), $size); +} + +sub is_same_file { + my ($file1, $file2) = @_; + + return 0 unless defined $file1; + return 0 unless defined $file2; + + return 1 if "$file1" eq "$file2"; + return 1 if clean_path($file1) eq clean_path($file2); + + return 0 unless -e $file1; + return 0 unless -e $file2; + + my ($dev1, $inode1) = stat($file1); + my ($dev2, $inode2) = stat($file2); + + return 0 unless $dev1 == $dev2; + return 0 unless $inode1 == $inode2; + return 1; +} + +sub looks_like_uuid { + my ($in) = @_; + + return undef unless defined $in; + return undef unless length($in) == 36; + return undef unless $in =~ m/^[0-9A-F\-]+$/i; + return $in; +} + +sub chmod_tmp { + my $file = shift; + + my $mode = S_ISVTX | S_IRWXU | S_IRWXG | S_IRWXO; + + chmod($mode, $file); +} + +sub process_includes { + my %params = @_; + + my @start = @{delete $params{list} // []}; + + my @list; + my %seen = ('.' => 1); + + if (my $ch_dir = delete $params{ch_dir}) { + for my $path (@start) { + # '.' is special. + $seen{'.'}++ and next if $path eq '.'; + + if (File::Spec->file_name_is_absolute($path)) { + push @list => $path; + } + else { + push @list => File::Spec->catdir($ch_dir, $path); + } + } + } + else { + @list = @start; + } + + push @list => @INC if delete $params{include_current}; + + @list = map { $_ eq '.' ? $_ : clean_path($_) || $_ } @list if delete $params{clean}; + + @list = grep { !$seen{$_}++ } @list; + + # If we ask for dot, or saw it during our processing, add it to the end. + push @list => '.' if delete($params{include_dot}) || $seen{'.'} > 1; + + confess "Invalid parameters: " . join(', ' => sort keys %params) if keys %params; + + return @list; +} + +sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); +} + +sub sig_name_to_num { $SIG_NUM_LOOKUP{$_} } +sub sig_num_to_name { $SIG_NAME_LOOKUP{$_} } + +sub parse_exit { + my ($exit) = @_; + + my $sig = $exit & 127; + my $dmp = $exit & 128; + + return { + $sig ? (signame => $SIG_NAME_LOOKUP{$sig} // 'N/A') : (), + sig => $sig, + err => ($exit >> 8), + dmp => $dmp, + all => $exit, + }; +} + +sub fqmod { + my ($prefix, $input) = @_; + return $1 if $input =~ m/^\+(.*)$/; + return "$prefix\::$input"; +} + +sub hub_truth { + my ($f) = @_; + + return $f->{hubs}->[0] if $f->{hubs} && @{$f->{hubs}}; + return $f->{trace} if $f->{trace}; + return {}; +} + +sub maybe_read_file { + my ($file) = @_; + return undef unless -f $file; + return read_file($file); +} + +sub read_file { + my ($file, @args) = @_; + + my $fh = open_file($file, '<', @args); + local $/; + my $out = <$fh>; + close_file($fh, $file); + + return $out; +} + +sub write_file { + my ($file, @content) = @_; + + my $fh = open_file($file, '>'); + print $fh @content; + close_file($fh, $file); + + return @content; +}; + +my %COMPRESSION = ( + bz2 => {module => 'IO::Uncompress::Bunzip2', errors => \$IO::Uncompress::Bunzip2::Bunzip2Error}, + gz => {module => 'IO::Uncompress::Gunzip', errors => \$IO::Uncompress::Gunzip::GunzipError}, +); +sub open_file { + my ($file, $mode, %opts) = @_; + $mode ||= '<'; + + unless ($opts{no_decompress}) { + if (my $ext = $opts{ext}) { + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($file =~ m/\.(gz|bz2)$/i) { + my $ext = lc($1); + $opts{compression} //= $COMPRESSION{$ext} or die "Unknown compression: $ext"; + } + + if ($mode eq '<' && $opts{compression}) { + my $spec = $opts{compression}; + my $mod = $spec->{module}; + require(mod2file($mod)); + + my $fh = $mod->new($file) or die "Could not open file '$file' ($mode): ${$spec->{errors}}"; + return $fh; + } + } + + open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!"; + return $fh; +} + +sub maybe_open_file { + my ($file, $mode) = @_; + return undef unless -f $file; + return open_file($file, $mode); +} + +sub close_file { + my ($fh, $name) = @_; + return if close($fh); + confess "Could not close file: $!" unless $name; + confess "Could not close file '$name': $!"; +} + +sub write_file_atomic { + my ($file, @content) = @_; + + my $pend = "$file.pend"; + + my ($ok, $err) = try_sig_mask { + write_file($pend, @content); + my ($ren_ok, $ren_err) = do_rename($pend, $file); + die "$pend -> $file: $ren_err" unless $ren_ok; + }; + + die $err unless $ok; + + return @content; +} + +sub lock_file { + my ($file, $mode) = @_; + + my $fh; + if (ref $file) { + $fh = $file; + } + else { + open($fh, $mode // '>>', $file) or die "Could not open file '$file': $!"; + } + + for (1 .. 21) { + flock($fh, LOCK_EX) and last; + die "Could not lock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not lock file: $!"; + } + + return $fh; +} + +sub unlock_file { + my ($fh) = @_; + for (1 .. 21) { + flock($fh, LOCK_UN) and last; + die "Could not unlock file (try $_): $!" if $_ >= 20; + next if $!{EINTR} || $!{ERESTART}; + die "Could not unlock file: $!"; + } + + return $fh; +} + +sub clean_path { + my ( $path, $absolute ) = @_; + + $absolute //= 1; + $path = realpath($path) // $path if $absolute; + + return File::Spec->rel2abs($path); +} + +sub mod2file { + my ($mod) = @_; + confess "No module name provided" unless $mod; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + return $file; +} + +sub file2mod { + my $file = shift; + my $mod = $file; + $mod =~ s{/}{::}g; + $mod =~ s/\..*$//; + return $mod; +} + + +sub find_libraries { + my ($search, @paths) = @_; + my @parts = grep $_, split /::(\*)?/, $search; + + @paths = @INC unless @paths; + + @paths = map { File::Spec->canonpath($_) } @paths; + + my %prefixes = map {$_ => 1} @paths; + + my @found; + my @bases = ([map { [$_ => length($_)] } @paths]); + while (my $set = shift @bases) { + my $new_base = []; + my $part = shift @parts; + + for my $base (@$set) { + my ($dir, $prefix) = @$base; + if ($part ne '*') { + my $path = File::Spec->catdir($dir, $part); + if (@parts) { + push @$new_base => [$path, $prefix] if -d $path; + } + elsif (-f "$path.pm") { + push @found => ["$path.pm", $prefix]; + } + + next; + } + + opendir(my $dh, $dir) or next; + for my $item (readdir($dh)) { + next if $item =~ m/^\./; + my $path = File::Spec->catdir($dir, $item); + if (@parts) { + # Sometimes @INC dirs are nested in eachother. + next if $prefixes{$path}; + + push @$new_base => [$path, $prefix] if -d $path; + next; + } + + next unless -f $path && $path =~ m/\.pm$/; + push @found => [$path, $prefix]; + } + } + + push @bases => $new_base if @$new_base; + } + + my %out; + for my $found (@found) { + my ($path, $prefix) = @$found; + + my @file_parts = File::Spec->splitdir(substr($path, $prefix)); + shift @file_parts if $file_parts[0] eq ''; + + my $file = join '/' => @file_parts; + $file_parts[-1] = substr($file_parts[-1], 0, -3); + my $module = join '::' => @file_parts; + + $out{$module} //= $file; + } + + return \%out; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util - General utiliy functions. + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 MISC + +=over 4 + +=item apply_encoding($fh, $enc) + +Apply the specified encoding to the filehandle. + +B<Justification>: +L<PERLBUG 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923> +If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in +order to avoid the thread segfault. + +This is a reusable implementation of this: + + sub apply_encoding { + my ($fh, $enc) = @_; + return unless $enc; + return binmode($fh, ":utf8") if $enc =~ m/^utf-?8$/i; + binmode($fh, ":encoding($enc)"); + } + +=item $clean = clean_path($path) + +Take a file path and clean it up to a minimal absolute path if possible. Always +returns a path, but if it cannot be cleaned up it is unchanged. + +=item $hashref = find_libraries($search) + +=item $hashref = find_libraries($search, @paths) + +C<@INC> is used if no C<@paths> are provided. + +C<$search> should be a module name with C<*> wildcards replacing sections. + + find_libraries('Foo::*::Baz') + find_libraries('*::Bar::Baz') + find_libraries('Foo::Bar::*') + +These all look for modules matching the search, this is a good way to find +plugins, or similar patterns. + +The result is a hashref of C<< { $module => $path } >>. If a module exists in +more than 1 search path the first is used. + +=item $mod = fqmod($prefix, $mod) + +This will automatically add C<$prefix> to C<$mod> with C<'::'> to join them. If +C<$mod> starts with the C<'+'> character the character will be removed and the +result returned without prepending C<$prefix>. + +=item hub_truth + +This is an internal implementation detail, do not use it. + +=item $hashref = parse_exit($?) + +This parses the exit value as typically stored in C<$?>. + +Resulting hash: + + { + sig => ($? & 127), # Signal value if the exit was caused by a signal + err => ($? >> 8), # Actual exit code, if any. + dmp => ($? & 128), # Was there a core dump? + all => $?, # Original exit value, unchanged + } + + +=item @list = process_includes(%PARAMS) + +This method will build up a list of include dirs fit for C<@INC>. The returned +list should contain only unique values, in proper order. + +Params: + +=over 4 + +=item list => \@START + +Paths to start the new list. + +Optional. + +=item ch_dir => $path + +Prefix to prepend to all paths in the C<list> param. No effect without an +initial list. + +=item include_current => $bool + +This will add all paths from C<@INC> to the output, after the initial list. +Note that '.', if in C<@INC> will be moved to the end of the final output. + +=item clean => $bool + +If included all paths except C<'.'> will be cleaned using C<clean_path()>. + +=item include_dot => $bool + +If true C<'.'> will be appended to the end of the output. + +B<Note> even if this is set to false C<'.'> may still be included if it was in +the initial list, or if it was in C<@INC> and C<@INC> was included using the +C<include_current> parameter. + +=back + +=back + +=head2 FOR DEALING WITH MODULE <-> FILE CONVERSION + +These convert between module names like C<Foo::Bar> and filenames like +C<Foo/Bar.pm>. + +=over 4 + +=item $file = mod2file($mod) + +=item $mod = file2mod($file) + +=back + +=head2 FOR READING/WRITING FILES + +=over 4 + +=item $fh = open_file($path, $mode) + +=item $fh = open_file($path) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = read_file($file) + +This will open the file at C<$path> and return all its contents. + +An exception will be thrown if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $fh = maybe_open_file($path) + +=item $fh = maybe_open_file($path, $mode) + +If no mode is provided C<< '<' >> is assumed. + +This will open the file at C<$path> and return a filehandle. + +C<undef> is returned if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item $text = maybe_read_file($path) + +This will open the file at C<$path> and return all its contents. + +This will return C<undef> if the file cannot be opened. + +B<NOTE:> This will automatically use L<IO::Uncompress::Bunzip2> or +L<IO::Uncompress::Gunzip> to uncompress the file if it has a .bz2 or .gz +extension. + +=item @content = write_file($path, @content) + +Write content to the specified file. This will open the file with mode +C<< '>' >>, write the content, then close the file. + +An exception will be thrown if any part fails. + +=item @content = write_file_atomic($path, @content) + +This will open a temporary file, write the content, close the file, then rename +the file to the desired C<$path>. This is essentially an atomic write in that +C<$file> will not exist until all content is written, preventing other +processes from doing a partial read while C<@content> is being written. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/Collector.pm b/liby/Test2/Harness/Util/Collector.pm new file mode 100644 index 000000000..b4a93a64b --- /dev/null +++ b/liby/Test2/Harness/Util/Collector.pm @@ -0,0 +1,344 @@ +package Test2::Harness::Util::Collector; +use strict; +use warnings; + +use Carp qw/croak cluck/; +use POSIX ":sys_wait_h"; +use Time::HiRes qw/sleep time/; +use Scalar::Util qw/reftype/; + +use Test2::Harness::Util qw/parse_exit apply_encoding/; +use Test2::Harness::Util::IPC qw/swap_io/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use Scope::Guard; +use Atomic::Pipe; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + event_cb + merge_outputs + buffer + state + children +}; + +sub init { + my $self = shift; + + croak "'state' is a required attribute" + unless $self->{+STATE}; + + croak "'event_cb' is a required attribute" + unless $self->{+EVENT_CB}; + + my $type = reftype($self->{+EVENT_CB}) // ''; + croak "'event_cb' must be a coderef, got '$self->{+EVENT_CB}'" + unless $type eq 'CODE'; + + $self->{+CHILDREN} //= {}; + $self->{+MERGE_OUTPUTS} //= 0; +} + +sub DESTROY { + my $self = shift; + + return unless $self->{+CHILDREN}; + for my $pid (keys %{$self->{+CHILDREN}}) { + next unless $$ == $self->{+CHILDREN}->{$pid}; + cluck("Failed to reap children parent process $$ when collector instance was destroyed"); + return $self->reap; + } +} + +sub reap { + my $self = shift; + my (@pids) = @_; + + unless (@pids) { + @pids = grep {$$ == $self->{+CHILDREN}->{$_}} keys %{$self->{+CHILDREN} // {}}; + } + return unless @pids; + + my @out; + + for my $pid (@pids) { + croak "$pid is not owned by this collector" + unless $self->{+CHILDREN}->{$pid} && $$ == $self->{+CHILDREN}->{$pid}; + + delete $self->{+CHILDREN}->{$pid}; + + my $check = waitpid($pid, 0); + my $exit = parse_exit($? // 0); + if ($check == $pid) { + push @out => $exit; + warn "Collector exited with a non-zero status (ERR: $exit->{err}, SIG: $exit->{sig})" if $exit->{all}; + $self->{+STATE}->transaction( + w => sub { + my ($state, $data) = @_; + delete $data->processes->{$pid}; + } + ); + } + else { + die("waitpid returned $check"); + } + } + + return @out; +} + +sub _warn { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + my $cb = $self->{+EVENT_CB}; + $self->_pre_event(frame => \@caller, facets => {info => [{tag => 'WARNING', details => $msg, debug => 1}]}); +} + +sub _die { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + $self->_pre_event(frame => \@caller, facets => {errors => [{tag => 'ERROR', details => $msg, fail => 1}]}); + + exit(255); +} + +sub run { + my $self = shift; + my %params = @_; + + my $name = $params{name} or croak "'name' is a required argument"; + my $type = $params{type} or croak "'type' is a required argument"; + my $launch_cb = $params{launch_cb} or croak "'launch_cb' is a required argument"; + + my $parent = $params{parent_pid}; + + if (!$parent) { + $parent = $$; + my $collector_pid = fork // CORE::die("Could not fork: $!"); + + if ($collector_pid) { + $self->{+CHILDREN}->{$collector_pid} = $$; + return $collector_pid; + } + } + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$} = {type => 'collector', parent => $parent, pid => $$, name => $name}; + }); + + my ($out_r, $out_w) = Atomic::Pipe->pair(mixed_data_mode => 1); + my ($err_r, $err_w) = $self->{+MERGE_OUTPUTS} ? ($out_r, $out_w) : Atomic::Pipe->pair(mixed_data_mode => 1); + + my $child_pid = fork // CORE::die("Could not fork: $!"); + + if (!$child_pid) { + swap_io(\*STDOUT, $out_w->wh, sub { $self->_die(@_) }); + swap_io(\*STDERR, $err_w->wh, sub { $self->_die(@_) }); + + $ENV{T2_HARNESS_USE_ATOMIC_PIPE} = $self->{+MERGE_OUTPUTS} ? 1 : 2; + { + no warnings 'once'; + $Test2::Harness::STDOUT_APIPE = $out_w; + $Test2::Harness::STDERR_APIPE = $err_w unless $self->{+MERGE_OUTPUTS}; + } + + eval { $launch_cb->(); 1 } or $self->_die($@ // "launch exception"); + + $self->_die("launch-cb returned, it should not do that!"); + } + + $self->_die("Failed to launch child '$type': '$name'") unless $child_pid; + + $self->{+CHILDREN}->{$child_pid} = $$; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$}->{children}->{$child_pid} = $child_pid; + $data->processes->{$child_pid} = {type => $type, parent => $$, pid => $child_pid, name => $name}; + }); + + $self->_die("Did not get a PID from launch callback (Did callback fail to exit when done?)") + unless $child_pid; + + my $stamp = time; + $self->_pre_event(stamp => $stamp, frame => [__PACKAGE__, __FILE__, __LINE__], process_launch => $child_pid); + + $SIG{INT} = sub { + $self->_warn("$$: Got SIGINT, forwarding to child process $child_pid.\n"); + kill('INT', $child_pid); + $SIG{INT} = 'DEFAULT'; + }; + $SIG{TERM} = sub { + $self->_warn("$$: Got SIGTERM, forwarding to child process $child_pid.\n"); + kill('TERM', $child_pid); + $SIG{TERM} = 'DEFAULT'; + }; + $SIG{PIPE} = 'IGNORE'; + + my $guard = Scope::Guard->new(sub { + eval { $self->_die("Scope Leak inside collector post-fork!") }; + exit(255); + }); + + $out_w->close; + $err_w->close; + + unless (eval { $self->_run(pid => $child_pid, stdout => $out_r, stderr => $err_r); 1 }) { + my $err = $@; + eval { + $guard->dismiss(); + $self->_die($err); + }; + exit(255); + } + + $guard->dismiss(); + exit(0); +} + +sub _run { + my $self = shift; + my %params = @_; + + $self->{+BUFFER} = {seen => {}, stderr => [], stdout => []}; + + my $pid = $params{pid}; + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + + $stdout->blocking(0); + $stderr->blocking(0); + + my @sets = (['stdout', $stdout]); + push @sets => ['stderr', $stderr] unless $self->{+MERGE_OUTPUTS}; + + my ($exited, $exit); + while (1) { + my $did_work = 0; + + unless ($exited) { + if (my $check = waitpid($pid, WNOHANG)) { + $exit = parse_exit($? // 0); + + delete $self->{+CHILDREN}->{$pid}; + if ($check == $pid) { + $exited = time; + $did_work++; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$}->{children}->{$pid}; + delete $data->processes->{$pid}; + }); + } + else { + die("waitpid returned $check"); + } + } + } + + my $enc; + + for my $set (@sets) { + my ($name, $fh) = @$set; + + my ($type, $val) = $fh->get_line_burst_or_data; + last unless $type; + $did_work++; + + if ($type eq 'message') { + my $decoded = decode_json($val); + $self->_add_item($name => $decoded); + } + elsif ($type eq 'line') { + chomp($val); + $self->_add_item($name => $val); + } + else { + chomp($val); + die("Invalid type '$type': $val"); + } + } + + next if $did_work; + last if $exited; + + sleep(0.02); + } + + $self->_flush(); + + $self->_pre_event(stamp => $exited, frame => [__PACKAGE__, __FILE__, __LINE__], process_exit => $exit); + + return; +} + +sub _add_item { + my $self = shift; + my ($stream, $val) = @_; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + push @{$buffer->{$stream}} => $val; + + $self->_flush() unless keys(%$seen); + + return unless ref($val); + + my $event_id = $val->{event_id} or die "Event has no ID!"; + + my $count = ++($seen->{$event_id}); + return unless $count >= ($self->{+MERGE_OUTPUTS} ? 1 : 2); + + $self->_flush(to => $event_id); +} + +sub _flush { + my $self = shift; + my %params = @_; + + my $to = $params{to}; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + for my $stream (qw/stderr stdout/) { + while (1) { + my $val = shift(@{$buffer->{$stream}}) or last; + if (ref($val)) { + # Send the event, unless it came via STDERR in which case it should only be a hashref with an event_id + $self->_pre_event(stream => $stream, data => $val) + unless $stream eq 'stderr'; + + last if $to && $val->{event_id} eq $to; + } + else { + $self->_pre_event(stream => $stream, line => $val); + } + } + } +} + +sub _pre_event { + my $self = shift; + my (%data) = @_; + + $data{stamp} //= time; + + my $cb = $self->{+EVENT_CB}; + $self->$cb(\%data); +} + +1; diff --git a/liby/Test2/Harness/Util/Collector.pm2 b/liby/Test2/Harness/Util/Collector.pm2 new file mode 100644 index 000000000..299dfae67 --- /dev/null +++ b/liby/Test2/Harness/Util/Collector.pm2 @@ -0,0 +1,281 @@ +package Test2::Harness::Util::Collector; +use strict; +use warnings; + +use Carp qw/croak/; +use POSIX ":sys_wait_h"; +use Time::HiRes qw/sleep time/; +use Scalar::Util qw/reftype/; + +use Test2::Harness::Util qw/parse_exit/; +use Test2::Harness::Util::JSON qw/decode_json/; + +use Scope::Guard; +use Atomic::Pipe; + +our $VERSION = '2.000000'; + +use Test2::Harness::Util::HashBase qw{ + event_cb + merge_outputs + buffer + state +}; + +sub init { + my $self = shift; + + croak "'state' is a required attribute" + unless $self->{+STATE}; + + croak "'event_cb' is a required attribute" + unless $self->{+EVENT_CB}; + + my $type = reftype($self->{+EVENT_CB}) // ''; + croak "'event_cb' must be a coderef, got '$self->{+EVENT_CB}'" + unless $type eq 'CODE'; + + $self->{+MERGE_OUTPUTS} //= 0; +} + +sub _warn { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + my $cb = $self->{+EVENT_CB}; + $self->_pre_event(frame => \@caller, facets => {info => [{tag => 'WARNING', details => $msg, debug => 1}]}); +} + +sub _die { + my $self = shift; + my ($msg) = @_; + + my @caller = caller(); + $msg .= " at $caller[1] line $caller[2].\n" unless $msg =~ m/\n$/; + + $self->_pre_event(frame => \@caller, facets => {errors => [{tag => 'ERROR', details => $msg, fail => 1}]}); + + exit(255); +} + +sub run { + my $self = shift; + my ($name, $type, $launch_cb) = @_; + + my $parent = $$; + my $collector_pid = fork // CORE::die("Could not fork: $!"); + + return $collector_pid if $collector_pid; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$} = {type => 'collector', parent => $parent, pid => $$, name => $name}; + }); + + $self->_warn("Add IPC process control for collector"); + + my ($out_r, $out_w) = Atomic::Pipe->pair(mixed_data_mode => 1); + my ($err_r, $err_w) = $self->{+MERGE_OUTPUTS} ? ($out_r, $out_w) : Atomic::Pipe->pair(mixed_data_mode => 1); + + close(STDOUT) or $self->_warn("Could not close STDOUT: $!"); + open(STDOUT, '>&', $out_w->wh) or $self->_die("Could not open STDOUT: $!"); + $self->_die("STDOUT got incorrect fileno: " . fileno(STDOUT)) unless fileno(STDOUT) == 1; + + close(STDERR) or $self->_warn("Could not close STDERR: $!"); + open(STDERR, '>&', $err_w->wh) or $self->_die("Could not open STDERR: $!"); + $self->_die("STDERR got incorrect fileno: " . fileno(STDERR)) unless fileno(STDERR) == 2; + + $ENV{T2_HARNESS_USE_ATOMIC_PIPE} = $self->{+MERGE_OUTPUTS} ? 1 : 2; + { + no warnings 'once'; + $Test2::Harness::STDOUT_APIPE = $out_w; + $Test2::Harness::STDERR_APIPE = $err_w unless $self->{+MERGE_OUTPUTS}; + } + + my $child_pid; + eval { $child_pid = $launch_cb->(); 1 } or $self->_die($@ // "Exception from launch_cb"); + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + $data->processes->{$$}->{children}->{$child_pid} = $child_pid; + $data->processes->{$child_pid} = {type => $type, parent => $$, pid => $child_pid, name => $name}; + }); + + $self->_die("Did not get a PID from launch callback (Did callback fail to exit when done?)") + unless $child_pid; + + my $stamp = time; + $self->_pre_event(stamp => $stamp, frame => [__PACKAGE__, __FILE__, __LINE__], process_launch => $child_pid); + + $SIG{INT} = sub { + $self->_warn("$$: Got SIGINT, forwarding to child process $child_pid.\n"); + kill('INT', $child_pid); + $SIG{INT} = 'DEFAULT'; + }; + $SIG{TERM} = sub { + $self->_warn("$$: Got SIGTERM, forwarding to child process $child_pid.\n"); + kill('TERM', $child_pid); + $SIG{TERM} = 'DEFAULT'; + }; + $SIG{PIPE} = 'IGNORE'; + + $self->_warn("Add IPC process control for test job"); + + my $guard = Scope::Guard->new(sub { + eval { $self->_die("Scope Leak!") }; + exit(255); + }); + + $SIG{__WARN__} = sub { $self->_warn($_) for @_ }; + + $out_w->close; + $err_w->close; + close(STDOUT); + close(STDERR); + + unless (eval { $self->_run(pid => $child_pid, stdout => $out_r, stderr => $err_r); 1 }) { + my $err = $@; + eval { + $guard->dismiss(); + $self->_die($err); + }; + exit(255); + } + + $guard->dismiss(); + exit(0); +} + +sub _run { + my $self = shift; + my %params = @_; + + $self->{+BUFFER} = {seen => {}, stderr => [], stdout => []}; + + my $pid = $params{pid}; + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + + $stdout->blocking(0); + $stderr->blocking(0); + + my @sets = (['stdout', $stdout]); + push @sets => ['stderr', $stderr] unless $self->{+MERGE_OUTPUTS}; + + my ($exited, $exit); + while (1) { + my $did_work = 0; + + unless ($exited) { + if (my $check = waitpid($pid, WNOHANG)) { + $exit = parse_exit($? // 0); + if ($check == $pid) { + $exited = time; + $did_work++; + + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + delete $data->processes->{$$}->{children}->{$pid}; + delete $data->processes->{$pid}; + }); + } + else { + die("waitpid returned $check"); + } + } + } + + for my $set (@sets) { + my ($name, $fh) = @$set; + + my ($type, $val) = $fh->get_line_burst_or_data; + last unless $type; + $did_work++; + + if ($type eq 'message') { + my $decoded = decode_json($val); + $self->_add_item($name => $decoded); + } + elsif ($type eq 'line') { + $self->_add_item($name => $val); + } + else { + chomp($val); + die("Invalid type '$type': $val"); + } + } + + next if $did_work; + last if $exited; + + sleep(0.02); + } + + $self->_flush(); + + $self->_pre_event(stamp => $exited, frame => [__PACKAGE__, __FILE__, __LINE__], process_exit => $exit); + + return; +} + +sub _add_item { + my $self = shift; + my ($stream, $val) = @_; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + push @{$buffer->{$stream}} => $val; + + $self->_flush() unless keys(%$seen); + + return unless ref($val); + + my $event_id = $val->{event_id} or die "Event has no ID!"; + + my $count = ++($seen->{$event_id}); + return unless $count >= ($self->{+MERGE_OUTPUTS} ? 1 : 2); + + $self->_flush(to => $event_id); +} + +sub _flush { + my $self = shift; + my %params = @_; + + my $to = $params{to}; + + my $buffer = $self->{+BUFFER} //= {}; + my $seen = $buffer->{seen} //= {}; + + for my $stream (qw/stderr stdout/) { + while (1) { + my $val = shift(@{$buffer->{$stream}}) or last; + if (ref($val)) { + # Send the event, unless it came via STDERR in which case it should only be a hashref with an event_id + $self->_pre_event(stream => $stream, data => $val) + unless $stream eq 'STDERR'; + + last if $to && $val->{event_id} eq $to; + } + else { + $self->_pre_event(stream => $stream, line => $val); + } + } + } +} + +sub _pre_event { + my $self = shift; + my (%data) = @_; + + $data{stamp} //= time; + + my $cb = $self->{+EVENT_CB}; + $self->$cb(\%data); +} + +1; diff --git a/liby/Test2/Harness/Util/File.pm b/liby/Test2/Harness/Util/File.pm new file mode 100644 index 000000000..6a19341f1 --- /dev/null +++ b/liby/Test2/Harness/Util/File.pm @@ -0,0 +1,256 @@ +package Test2::Harness::Util::File; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use IO::Handle; + +use Test2::Harness::Util(); + +use Carp qw/croak confess/; +use Fcntl qw/SEEK_SET SEEK_CUR/; + +use Test2::Harness::Util::HashBase qw{ -name -_fh -_init_fh done -line_pos <skip_bad_decode }; + +sub exists { -e $_[0]->{+NAME} } + +sub decode { shift; $_[0] } +sub encode { shift; $_[0] } + +sub init { + my $self = shift; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + $self->{+_INIT_FH} = delete $self->{fh}; +} + +sub open_file { + my $self = shift; + return Test2::Harness::Util::open_file($self->{+NAME}, @_) +} + +sub maybe_read { + my $self = shift; + return undef unless -e $self->{+NAME}; + return $self->read; +} + +sub read { + my $self = shift; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +sub rewrite { + my $self = shift; + return Test2::Harness::Util::write_file($self->{+NAME}, $self->encode(@_)); +} + +sub write { + my $self = shift; + return Test2::Harness::Util::write_file_atomic($self->{+NAME}, $self->encode(@_)); +} + +sub reset { + my $self = shift; + delete $self->{+_FH}; + delete $self->{+DONE}; + delete $self->{+LINE_POS}; + return; +} + +sub fh { + my $self = shift; + return $self->{+_FH}->{$$} if $self->{+_FH}->{$$}; + + # Remove any other PID handles + $self->{+_FH} = {}; + + if (my $fh = $self->{+_INIT_FH}) { + $self->{+_FH}->{$$} = $fh; + } + else { + $self->{+_FH}->{$$} = Test2::Harness::Util::maybe_open_file($self->{+NAME}) or return undef; + } + + $self->{+_FH}->{$$}->blocking(0); + return $self->{+_FH}->{$$}; +} + +sub read_line { + my $self = shift; + my %params = @_; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + my $fh = $self->{+_FH}->{$$} || $self->fh or return undef; + seek($fh,$pos,SEEK_SET) or die "Could not seek: $!" + if eof($fh) || tell($fh) != $pos; + + my $line = <$fh>; + + # No line, nothing to do + return unless defined $line && length($line); + + # Partial line, hold off unless done + return unless $self->{+DONE} || substr($line, -1, 1) eq "\n"; + + my $new_pos = tell($fh); + die "Failed to 'tell': $!" if $new_pos == -1; + + my $err = 0; + local $@; + unless (eval { $line = $self->decode($line); 1 }) { + $err = $@ // 'error'; + confess "$self->{+NAME} ($pos -> $new_pos): $err" unless $self->{+SKIP_BAD_DECODE}; + warn "Skipping line that failed to decode: $err\n" if $self->{+SKIP_BAD_DECODE} > 1; + $line = undef; + } + + $self->{+LINE_POS} = $new_pos unless defined $params{peek} || defined $params{from}; + return $line unless wantarray; + return ($pos, $new_pos, $line, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File - Utility class for manipulating a file. + +=head1 DESCRIPTION + +This is a utility class for file operations. This also serves as a base class +for several file helpers. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File; + + my $f = Test2::Harness::Util::File->new(name => '/path/to/file'); + + $f->write($content); + + my $fh = $f->open_file('<'); + + # Read, throw exception if it cannot read + my $content = $f->read(); + + # Try to read, but do not throw an exception if it cannot be read. + my $content_or_undef = $f->maybe_read(); + + my $line1 = $f->read_line(); + my $line2 = $f->read_line(); + ... + +=head1 ATTRIBUTES + +=over 4 + +=item $filename = $f->name; + +Get the filename. Must also be provided during construction. + +=item $bool = $f->done; + +True if read_line() has read every line. + +=back + +=head1 METHODS + +=over 4 + +=item $decoded = $f->decode($encoded) + +This is a no-op, it returns the argument unchanged. This is called by C<read> +and C<read_line>. Subclasses can override this if the file contains encoded +data. + +=item $encoded = $f->encode($decoded) + +This is a no-op, it returns the argument unchanged. This is called by C<write>. +Subclasses can override this if the file contains encoded data. + +=item $bool = $f->exists() + +Check if the file exists + +=item $content = $f->maybe_read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will return undef. + +=item $fh = $f->open_file() + +=item $fh = $f->open_file($mode) + +Open a handle to the file. If no $mode is provided C<< '<' >> is used. + +=item $content = $f->read() + +This will read the file if it can and return the content (all lines joined +together as a single string). If the file cannot be read, or does not exist +this will throw an exception. + +=item $line = $f->read_line() + +Read a single line from the file, subsequent calls will read the next line and +so on until the end of the file is reached. Reset with the C<reset()> method. + +=item $f->reset() + +Reset the internal line iterator used by C<read_line()>. + +=item $f->write($content) + +This is an atomic-write. First $content will be written to a temporary file +using C<< '>' >> mode. Then the temporary file will be renamed to the desired +file name. Under the hood this uses C<write_file_atomic()> from +L<Test2::Harness::Util>. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/File/JSON.pm b/liby/Test2/Harness/Util/File/JSON.pm new file mode 100644 index 000000000..f3f6c5a1e --- /dev/null +++ b/liby/Test2/Harness/Util/File/JSON.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSON; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak confess/; +use Test2::Harness::Util::JSON qw/encode_json decode_json encode_pretty_json/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/pretty/; + +sub decode { shift; decode_json(@_) } +sub encode { shift->pretty ? encode_pretty_json(@_) : encode_json(@_) } + +sub reset { croak "line reading is disabled for json files" } +sub read_line { croak "line reading is disabled for json files" } + +sub maybe_read { + my $self = shift; + + return undef unless -e $self->{+NAME}; + my $out = Test2::Harness::Util::read_file($self->{+NAME}); + + return undef unless defined($out) && length($out); + + eval { $out = $self->decode($out); 1 } or confess "$self->{+NAME}: $@"; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSON - Utility class for a JSON file. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> which automatically handles +encoding/decoding JSON data. + +=head1 SYNOPSIS + + require Test2::Harness::Util::File::JSON; + my $file = Test2::Harness::Util::File::JSON->new(name => '/path/to/file.json'); + + $hash = $file->read; + # or + $$file->write({...}); + +=head1 SEE ALSO + +See the base class L<Test2::Harness::Util::File> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/File/JSONL.pm b/liby/Test2/Harness/Util/File/JSONL.pm new file mode 100644 index 000000000..ce64c51b3 --- /dev/null +++ b/liby/Test2/Harness/Util/File/JSONL.pm @@ -0,0 +1,91 @@ +package Test2::Harness::Util::File::JSONL; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util::JSON qw/encode_json decode_json/; + +use parent 'Test2::Harness::Util::File::Stream'; +use Test2::Harness::Util::HashBase; + +sub decode { shift; decode_json($_[0]) } +sub encode { shift; encode_json(@_) . "\n" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::JSONL - Utility class for a JSONL file (stream) + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> which automatically handles +encoding/decoding JSONL data. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + while (1) { + my @items = $jsonl->poll(max => 1000) or last; + for my $item (@items) { + ... handle $item ... + } + } + +or + + use Test2::Harness::Util::File::JSONL; + + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => '/path/to/file.jsonl'); + + $jsonl->write({my => 'item', ... }); + ... + +=head1 SEE ALSO + +See the base classes L<Test2::Harness::Util::File> and +L<Test2::Harness::Util::File::Stream> for methods. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/File/Stream.pm b/liby/Test2/Harness/Util/File/Stream.pm new file mode 100644 index 000000000..e69950852 --- /dev/null +++ b/liby/Test2/Harness/Util/File/Stream.pm @@ -0,0 +1,221 @@ +package Test2::Harness::Util::File::Stream; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/lock_file unlock_file/; +use Fcntl qw/SEEK_SET/; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase qw/use_write_lock -tail +_wfh +_wpid/; + +sub init { + my $self = shift; + + $self->SUPER::init(); + + my $tail = $self->{+TAIL} or return; + + return unless $self->exists; + + my @lines = $self->poll_with_index; + if (@lines < $self->{+TAIL}) { + $self->seek(0); + } + else { + $self->seek($lines[0 - $tail]->[0]); + } +} + +sub poll_with_index { + my $self = shift; + my %params = @_; + + my $max = delete $params{max} || 0; + + my $pos = $params{from}; + $pos = $self->{+LINE_POS} ||= 0 unless defined $pos; + + warn "Test This!!!"; # Added for 2.0 + return unless $pos < -s $self->name; + + my @out; + while (!$max || @out < $max) { + my ($spos, $epos, $line, $err) = $self->read_line(%params, from => $pos); + last unless defined($line) || defined($spos) || defined($epos) || $err; + + $self->{+LINE_POS} = $epos unless $params{peek} || defined $params{from}; + push @out => [$spos, $epos, $line] unless $err; + $pos = $epos; + } + + return @out; +} + +sub read { + my $self = shift; + + return $self->poll(from => 0); +} + +sub poll { + my $self = shift; + my @lines = $self->poll_with_index(@_); + return map { $_->[-1] } @lines; +} + +sub write { + my $self = shift; + + my $name = $self->{+NAME}; + + my $fh; + if ($self->{+USE_WRITE_LOCK}) { + $fh = lock_file($self->name, '>>'); + $fh->autoflush(1); + } + else { + unless ($self->{+_WPID} && $self->{+_WPID} == $$) { + delete $self->{+_WFH}; + $self->{+_WPID} = $$; + } + + if ($fh = $self->{+_WFH}) { + seek($fh, 2, 0); + } + else { + $fh = $self->{+_WFH} = Test2::Harness::Util::open_file($self->name, '>>'); + $fh->autoflush(1); + } + } + + print {$fh} $self->encode($_) for @_; + + if ($self->{+USE_WRITE_LOCK}) { + unlock_file($fh); + close($fh) or die "Could not close file '$name': $!"; + } + + return @_; +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + my $fh = $self->fh; + my $name = $self->{+NAME}; + + seek($fh, $pos, SEEK_SET) or die "Could not seek to position $pos in file '$name': $!"; + $self->{+LINE_POS} = $pos; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Stream - Utility class for manipulating a file that +serves as an output stream. + +=head1 DESCRIPTION + +Subclass of L<Test2::Harness::File> that streams the contents of a file, even +if the file is still being written. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Stream; + + my $stream = Test2::Harness::Util::File::Stream->new(name => 'path/to/file'); + + # Read some lines + my @lines = $stream->poll; + + ... + + # Read more lines, if any. + push @lines => $stream->poll; + +=head1 ATTRIBUTES + +See L<Test2::Harness::File> for additional attributes. + +These can be passed in as construction arguments if desired. + +=over 4 + +=item $bool = $stream->use_write_lock + +=item $stream->use_write_lock($bool) + +Lock the file for every C<write()> operation. + +=item $bool = $stream->tail + +Start near the end of the file and only poll for updates appended to it. + +=back + +=head1 METHODS + +See L<Test2::Harness::File> for additional methods. + +=over 4 + +=item @lines = $stream->read() + +Read all lines from the beginning. Every time it is called it returns ALL lines. + +=item @lines = $stream->poll() + +=item @lines = $stream->poll(max => $int) + +Poll for lines. This is an iterator, it should not return the same line more +than once, you can call it multiple times to get any additional lines that have +been added since the last poll. + +=item $stream->write(@content) + +Append @content to the file. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/File/Value.pm b/liby/Test2/Harness/Util/File/Value.pm new file mode 100644 index 000000000..bf291ba5b --- /dev/null +++ b/liby/Test2/Harness/Util/File/Value.pm @@ -0,0 +1,100 @@ +package Test2::Harness::Util::File::Value; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use parent 'Test2::Harness::Util::File'; +use Test2::Harness::Util::HashBase; + +sub init { + my $self = shift; + $self->{+DONE} = 1; +} + +sub read { + my $self = shift; + my $out = $self->SUPER::read(@_); + chomp($out) if defined $out; + return $out; +} + +sub read_line { + my $self = shift; + my $out = $self->SUPER::read_line(@_); + chomp($out) if defined $out; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::File::Value - Utility class for a file that contains +exactly 1 value. + +=head1 DESCRIPTION + +This is a subclass of L<Test2::Harness::Util::File> for files expected to have +exactly 1 value stored in them. + +=head1 SYNOPSIS + + use Test2::Harness::Util::File::Value; + + my $vf = Test2::Harness::Util::File::Value->new(name => 'path/to/file'); + my $val = $vf->read; + +=head1 METHODS + +=over 4 + +=item $val = $vf->read() + +Read all contents from the file, C<chomp()> it, and return it. + +=item $val = $vf->read_line() + +Read the first line from the file, C<chomp()> it, and return it. Note, this +may not return anything if the value in the file does not terminate with a +newline. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/HashBase.pm b/liby/Test2/Harness/Util/HashBase.pm new file mode 100644 index 000000000..0146e1c7c --- /dev/null +++ b/liby/Test2/Harness/Util/HashBase.pm @@ -0,0 +1,473 @@ +package Test2::Harness::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Harness::Util::HashBase::HB_VERSION = '0.008'; + *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Harness::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub import { + my $class = shift; + my $into = caller; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Harness::Util::HashBase::HB_VERSION || $Test2::Harness::Util::HashBase::VERSION; + $Test2::Harness::Util::HashBase::VERSION{$into} = $ver if !$Test2::Harness::Util::HashBase::VERSION{$into} || $Test2::Harness::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Harness::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Harness::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Harness::Util::HashBase>. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Harness::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B<Note:> Test2::Harness::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Harness::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'s key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Harness::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Harness::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Harness::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Harness::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Harness::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Harness::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Harness::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Harness::Util::HashBase class. + +=over 4 + +=item @list = Test2::Harness::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Harness::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/IPC.pm b/liby/Test2/Harness/Util/IPC.pm new file mode 100644 index 000000000..88e45a35f --- /dev/null +++ b/liby/Test2/Harness/Util/IPC.pm @@ -0,0 +1,326 @@ +package Test2::Harness::Util::IPC; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Cwd qw/getcwd/; +use Config qw/%Config/; +use Test2::Util qw/CAN_REALLY_FORK/; + +use Importer Importer => 'import'; + +our @EXPORT_OK = qw{ + USE_P_GROUPS + run_cmd + swap_io +}; + +BEGIN { + if ($Config{'d_setpgrp'}) { + *USE_P_GROUPS = sub() { 1 }; + } + else { + *USE_P_GROUPS = sub() { 0 }; + } +} + +if (CAN_REALLY_FORK) { + *run_cmd = \&_run_cmd_fork; +} +else { + *run_cmd = \&_run_cmd_spwn; +} + +sub swap_io { + my ($fh, $to, $die, $mode) = @_; + + $die ||= sub { + my @caller = caller; + my @caller2 = caller(1); + die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); + }; + + my $orig_fd; + if (ref($fh) eq 'ARRAY') { + ($orig_fd, $fh) = @$fh; + } + else { + $orig_fd = fileno($fh); + } + + $die->("Could not get original fd ($fh)") unless defined $orig_fd; + + if (ref($to)) { + $mode //= $orig_fd ? '>&' : '<&'; + open($fh, $mode, $to) or $die->("Could not redirect output: $!"); + } + else { + $mode //= $orig_fd ? '>' : '<'; + open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); + } + + return if fileno($fh) == $orig_fd; + + $die->("New handle does not have the desired fd!"); +} + +sub _run_cmd_fork { + my %params = @_; + + my $cmd = $params{command} or die "No 'command' specified"; + + my $pid = fork; + die "Failed to fork" unless defined $pid; + if ($pid) { + $_->() for @{$params{run_in_parent} // []}; + return $pid; + } + else { + $_->() for @{$params{run_in_child} // []}; + } + %ENV = (%ENV, %{$params{env}}) if $params{env}; + setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp}; + + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + if (my $dir = $params{chdir} // $params{ch_dir}) { + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDERR, $stderr, $die) if $stderr; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + swap_io(\*STDIN, $stdin, $die) if $stdin; + open(STDIN, "<", "/dev/null") if !$stdin; + + @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd; + + exec(@$cmd) or $die->("Failed to exec!"); +} + +sub _run_cmd_spwn { + my %params = @_; + + local %ENV = (%ENV, %{$params{env}}) if $params{env}; + + my $cmd = $params{command} or die "No 'command' specified"; + $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; + + my $cwd; + if (my $dir = $params{chdir} // $params{ch_dir}) { + $cwd = getcwd(); + chdir($dir) or die "Could not chdir: $!"; + } + + my $stdout = $params{stdout}; + my $stderr = $params{stderr}; + my $stdin = $params{stdin}; + + open(my $OLD_STDIN, '<&', \*STDIN) or die "Could not clone STDIN: $!"; + open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!"; + open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; + + my $die = sub { + my $caller1 = $params{caller1}; + my $caller2 = $params{caller2}; + my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"; + print $OLD_STDERR $msg; + print STDERR $msg; + POSIX::_exit(127); + }; + + swap_io(\*STDIN, $stdin, $die) if $stdin; + swap_io(\*STDOUT, $stdout, $die) if $stdout; + $stdin ? swap_io(\*STDIN, $stdin, $die) : close(STDIN); + + local $?; + my $pid; + my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd }; + my $bad = $?; + my $err = $@; + + swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die); + swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr; + swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout; + + if ($cwd) { + chdir($cwd) or die "Could not chdir: $!"; + } + + die $err unless $ok; + die "Spawn resulted in code $bad" if $bad && $bad != $pid; + die "Failed to spawn" unless $pid; + + $_->() for @{$params{run_in_parent} // []}; + + return $pid; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::IPC - Utilities for IPC management. + +=head1 DESCRIPTION + +This package provides low-level IPC tools for Test2::Harness. + +=head1 EXPORTS + +All exports are optional and must be specified at import time. + +=over 4 + +=item $bool = USE_P_GROUPS() + +This is a shortcut for: + + use Config qw/%Config/; + $Config{'d_setpgrp'}; + +=item swap_io($from, $to) + +=item swap_io($from, $to, \&die) + +This will close and re-open the file handle designated by C<$from> so that it +redirects to the handle specified in C<$to>. It preserves the file descriptor +in the process, and throws an exception if it fails to do so. + + swap_io(\*STDOUT, $fh); + # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'. + +As long as the file descriptor is greater than 0 it will open for writing. If +the descriptor is 0 it will open for reading, allowing for a swap of C<STDIN> +as well. + +Extra effort is made to insure errors go to the real C<STDERR>, specially when +trying to swap out C<STDERR>. If you have trouble with this, or do not trust +it, you can provide a custom coderef as a third argument, this coderef will be +used instead of C<die()> to throw exceptions. + +Note that the custom die logic when you do not provide your own bypasses the +exception catching mechanism and will exit your program. If this is not +desirable then you should provide a custom die subref. + +=item $pid = run_cmd(command => [...], %params) + +This function will run the specified command and return a pid to you. When +possible this will be done via C<fork()> and C<exec()>. When that is not +possible it uses the C<system(1, ...)> trick to spawn a new process. Some +parameters do not work in the second case, and are silently ignored. + +Parameters: + +=over 4 + +=item command => [$command, sub { ... }, @args] + +=item command => sub { return ($command, @args) } + +This parameter is required. This should either be an arrayref of arguments for +C<exec()>, or a coderef that returns a list of arguments for C<exec()>. On +systems without fork/exec the arguments will be passed to +C<system(1, $command, @args)> instead. + +If the command arrayref has a coderef in it, the coderef will be run and its +return value(s) will be inserted in its place. This replacement happens +post-chroot + +=item run_in_parent => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the parent process immedietly after the +child process is started. + +=item run_in_child => [sub { ... }, sub { ... }] + +An arrayref of callbacks to be run in the child process immedietly after fork. +This parameter is silently ignored on systems without fork/exec. + +=item env => { ENVVAR => $VAL, ... } + +A hashref of custom environment variables to set in the child process. In the +fork/exec model this is done post-fork, in the spawn model this is done via +local prior to the spawn. + +=item no_set_pgrp => $bool, + +Normall C<setpgrp(0,0)> is called on systems where it is supported. You can use +this parameter to override the normal behavior. setpgrp() is not called in the +spawn model, so this parameter is silently ignored there. + +=item chdir => 'path/to/dir' + +=item ch_dir => 'path/to/dir' + +chdir() to the specified directory for the new process. In the fork/exec model +this is done post-fork in the child. In the spawn model this is done before the +spawn, then a second chdir() puts the parent process back to its original dir +after the spawn. + +=item stdout => $handle + +=item stderr => $handle + +=item stdin => $handle + +Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec +model these are swapped into place post-fork in the child. In the spawn model +the swap occurs pre-spawn, then the old handles are swapped back post-spawn. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/JSON.pm b/liby/Test2/Harness/Util/JSON.pm new file mode 100644 index 000000000..2c73ec443 --- /dev/null +++ b/liby/Test2/Harness/Util/JSON.pm @@ -0,0 +1,263 @@ +package Test2::Harness::Util::JSON; +use strict; +use warnings; + +use Carp qw/croak/; + +our $VERSION = '1.000152'; + +BEGIN { + local $@ = undef; + my $ok = eval { + require JSON::MaybeXS; + JSON::MaybeXS->import('JSON'); + 1; + + if (JSON() eq 'JSON::PP') { + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + elsif (JSON() eq 'JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 1 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + elsif (JSON() eq 'Cpanel::JSON::XS') { + *JSON_IS_PP = sub() { 0 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 1 }; + *JSON_IS_CPANEL_OR_XS = sub() { 1 }; + } + }; + + unless ($ok) { + require JSON::PP; + *JSON = sub() { 'JSON::PP' }; + + *JSON_IS_PP = sub() { 1 }; + *JSON_IS_XS = sub() { 0 }; + *JSON_IS_CPANEL = sub() { 0 }; + *JSON_IS_CPANEL_OR_XS = sub() { 0 }; + } + +} + +our @EXPORT = qw{JSON encode_json decode_json encode_pretty_json encode_canon_json stream_json_l stream_json_l_file stream_json_l_url}; +our @EXPORT_OK = qw{JSON_IS_PP JSON_IS_XS JSON_IS_CPANEL JSON_IS_CPANEL_OR_XS}; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $json = JSON->new->utf8(1)->convert_blessed(1)->allow_nonref(1); +my $json_non_utf8 = JSON->new->utf8(0)->convert_blessed(1)->allow_nonref(1); +my $canon = JSON->new->utf8(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); +my $pretty = JSON->new->utf8(1)->pretty(1)->canonical(1)->convert_blessed(1)->allow_nonref(1); + +sub encode_json { $json->encode(@_) } +sub encode_canon_json { $canon->encode(@_) } +sub encode_pretty_json { $pretty->encode(@_) } + +sub decode_json { + my ($input) = @_; + my $data; + + local $@; + my $error; + + # Try to decode the JSON stream as utf8. In malformed tests or tests which are intentionally + # testing bytes behavior we need to accept the bytes from the JSON file instead. + my $ok = eval { $data = $json->decode($input); 1 } || do { + $error = $@; + eval { $data = $json_non_utf8->decode($input); 1 }; + }; + $error ||= $@; + return $data if $ok; + my $mess = Carp::longmess("JSON decode error: $error"); + die "$mess\n=======\n$input\n=======\n"; +} + +sub stream_json_l { + my ($path, $handler, %params) = @_; + + croak "No path provided" unless $path; + + return stream_json_l_file($path, $handler) if -f $path; + return stream_json_l_url($path, $handler, %params) if $path =~ m{^https?://}; + + croak "'$path' is not a valid path (file does not exist, or is not an http(s) url)"; +} + +sub stream_json_l_file { + my ($path, $handler) = @_; + + croak "Invalid file '$path'" unless -f $path; + + croak "Path must have a .json or .jsonl extension with optional .gz or .bz2 postfix." + unless $path =~ m/\.(json(?:l)?)(?:.(?:bz2|gz))?$/; + + if ($1 eq 'json') { + require Test2::Harness::Util::File::JSON; + my $json = Test2::Harness::Util::File::JSON->new(name => $path); + $handler->($json->read); + } + else { + require Test2::Harness::Util::File::JSONL; + my $jsonl = Test2::Harness::Util::File::JSONL->new(name => $path); + while (my ($item) = $jsonl->poll(max => 1)) { + $handler->($item); + } + } + + return 1; +} + +sub stream_json_l_url { + my ($path, $handler, %params) = @_; + my $meth = $params{http_method} // 'get'; + my $args = $params{http_args} // []; + + require HTTP::Tiny; + my $ht = HTTP::Tiny->new(); + + my $buffer = ''; + my $iterate = sub { + my ($res) = @_; + + my @parts = split /(\n)/, $buffer; + + while (@parts > 1) { + my $line = shift @parts; + my $nl = shift @parts; + my $data; + unless (eval { $data = decode_json($line); 1 }) { + warn "Unable to decode json for chunk when parsing json/l chunk:\n----\n$line\n----\n$@\n----\n"; + next; + } + + $handler->($data, $res); + } + + $buffer = shift @parts // ''; + }; + + my $res = $ht->$meth( + $path, + { + @$args, + data_callback => sub { + my ($chunk, $res) = @_; + $buffer .= $chunk; + $iterate->($res); + }, + } + ); + + if (length($buffer)) { + $buffer .= "\n" unless $buffer =~ m/\n$/; + $iterate->($res); + } + + return $res; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::JSON - Utility class to help Test2::Harness pick the best +JSON implementation. + +=head1 DESCRIPTION + +This package provides functions for encoding/decoding json, and uses the best +json tools available. + +=head1 SYNOPSIS + + use Test2::Harness::Util::JSON qw/encode_json decode_json/; + + my $data = { foo => 1 }; + my $json = encode_json($data); + my $copy = decode_json($json); + +=head1 EXPORTS + +=over 4 + +=item $package = JSON() + +This returns the JSON package being used by yath. + +=item $bool = JSON_IS_PP() + +True if yath is using L<JSON::PP>. + +=item $bool = JSON_IS_XS() + +True if yath is using L<JSON::XS>. + +=item $bool = JSON_IS_CPANEL() + +True if yath is using L<Cpanel::JSON::XS>. + +=item $bool = JSON_IS_CPANEL_OR_XS() + +True if either L<JSON::XS> or L<Cpanel::JSON::XS> are being used. + +=item $string = encode_json($data) + +Encode data into json. String will be 1-line. + +=item $data = decode_json($string) + +Decode json data from the string. + +=item $string = encode_pretty_json($data) + +Encode into human-friendly json. + +=item $string = encode_canon_json($data) + +Encode into canon-json. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/Queue.pm b/liby/Test2/Harness/Util/Queue.pm new file mode 100644 index 000000000..efe7289b3 --- /dev/null +++ b/liby/Test2/Harness/Util/Queue.pm @@ -0,0 +1,213 @@ +package Test2::Harness::Util::Queue; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/write_file_atomic/; + +use Test2::Harness::Util::File::JSONL(); + +use Test2::Harness::Util::HashBase qw{ + -file -qh -ended +}; + +sub init { + my $self = shift; + + croak "'file' is a required attribute" + unless $self->{+FILE}; +} + +sub start { + my $self = shift; + write_file_atomic($self->{+FILE}, ""); +} + +sub seek { + my $self = shift; + my ($pos) = @_; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + $self->{+QH}->seek($pos); + + return $pos; +} + +sub reset { + my $self = shift; + delete $self->{+QH}; +} + +sub poll { + my $self = shift; + my $max = shift; + + return $self->{+ENDED} if $self->{+ENDED}; + + $self->{+QH} ||= Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}); + my @out = $self->{+QH}->poll_with_index( $max ? (max => $max) : () ); + + $self->{+ENDED} = $out[-1] if @out && !defined($out[-1]->[-1]); + + return @out; +} + +sub end { + my $self = shift; + $self->_enqueue(undef); +} + +sub enqueue { + my $self = shift; + my ($task) = @_; + + croak "Invalid task" + unless $task && ref($task) eq 'HASH' && values %$task; + + $task->{stamp} ||= time; + + $self->_enqueue($task); +} + +sub _enqueue { + my $self = shift; + my ($task) = @_; + + my $fh = Test2::Harness::Util::File::JSONL->new(name => $self->{+FILE}, use_write_lock => 1); + $fh->write($task); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Queue - Representation of a queue. + +=head1 DESCRIPTION + +This module represents a queue, stored as a jsonl file. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + $queue->start(); # Create the queue + + $queue->enqueue({foo => 'bar', baz => 'bat'}); + $queue->enqueue({foo => 'bar2', baz => 'bat2'}); + ... + + $queue->end(); + +Then in another processs: + + use Test2::Harness::Util::Queue; + + my $queue = Test2::Harness::Util::Queue->new(file => '/path/to/queue.jsonl'); + + my @items; + while (1) { + @items = $queue->poll(); + while (@items) { + my $item = shift @items or last; + + ... process $item + } + + # Queue ends with an 'undef' entry + last if @items && !defined($items[0]); + } + +=head1 METHODS + +=over 4 + +=item $path = $queue->file + +The filename used for the queue + +=back + +=head2 READING + +=over 4 + +=item $queue->reset() + +Restart reading the queue. + +=item @items = $queue->poll() + +Get more items from the queue. May need to call it multiple times, specially if +another process is still writing to the queue. + +Returns an empty list if no items are available yet. + +Returns 'undef' to terminate the list. + +=item $bool = $queue->ended() + +Check if the queue has ended. + +=back + +=head1 WRITING + +=over 4 + +=item $queue->start() + +Open the queue file for writing. + +=item $queue->enqueue(\%HASHREF) + +Add an item to the queue. + +=item $queue->end() + +Terminate the queue. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/Term.pm b/liby/Test2/Harness/Util/Term.pm new file mode 100644 index 000000000..da0b6a306 --- /dev/null +++ b/liby/Test2/Harness/Util/Term.pm @@ -0,0 +1,104 @@ +package Test2::Harness::Util::Term; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Util qw/IS_WIN32/; + +use Importer Importer => 'import'; +our @EXPORT_OK = qw/USE_ANSI_COLOR/; + +{ + my $use = 0; + local ($@, $!); + + if (eval { require Term::ANSIColor; Term::ANSIColor->VERSION('4.03') }) { + if (IS_WIN32) { + if (eval { require Win32::Console::ANSI }) { + Win32::Console::ANSI->import(); + $use = 1; + } + } + else { + $use = 1; + } + } + + if ($use) { + *USE_ANSI_COLOR = sub() { 1 }; + } + else { + *USE_ANSI_COLOR = sub() { 0 }; + } +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::Term - Terminal utilities for Test2::Harness + +=head1 DESCRIPTION + +This module provides information about the terminal in which the harness is +running. + +=head1 SYNOPSIS + + use Test2::Harness::Util::Term qw/USE_ANSI_COLOR/; + + if (USE_ANSI_COLOR) { + ... + } + else { + ... + } + +=head1 EXPORTS + +=over 4 + +=item $bool = USE_ANSI_COLOR() + +True if L<Term::ANSIColor> is available and usable. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Harness/Util/UUID.pm b/liby/Test2/Harness/Util/UUID.pm new file mode 100644 index 000000000..459bea92e --- /dev/null +++ b/liby/Test2/Harness/Util/UUID.pm @@ -0,0 +1,85 @@ +package Test2::Harness::Util::UUID; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Data::UUID; +use Importer 'Importer' => 'import'; + +our @EXPORT = qw/gen_uuid/; +our @EXPORT_OK = qw/UG gen_uuid/; + +my ($UG, $UG_PID); +sub UG { + return $UG if $UG && $UG_PID && $UG_PID == $$; + + $UG_PID = $$; + return $UG = Data::UUID->new; +} + +sub gen_uuid { UG()->create_str() } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Util::UUID - Utils for generating UUIDs. + +=head1 DESCRIPTION + +This module provides a consistent UUID source for all of Test2::Harness. + +=head1 SYNOPSIS + + use Test2::Harness::Util::UUID qw/gen_uuid/; + + my $uuid = gen_uuid; + +=head1 EXPORTS + +=over 4 + +=item $uuid = gen_uuid() + +Generate a UUID. + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/liby/Test2/Tools/HarnessTester.pm b/liby/Test2/Tools/HarnessTester.pm new file mode 100644 index 000000000..e48090390 --- /dev/null +++ b/liby/Test2/Tools/HarnessTester.pm @@ -0,0 +1,179 @@ +package Test2::Tools::HarnessTester; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use App::Yath::Tester qw/make_example_dir/; + +use Importer Importer => qw/import/; +our @EXPORT_OK = qw/make_example_dir summarize_events/; + +my $HARNESS_ID = 1; +sub summarize_events { + my ($events) = @_; + + my @caller = caller(0); + + my $id = $HARNESS_ID++; + my $run_id = "run-$id"; + my $job_id = "job-$id"; + + require Test2::Harness::Auditor::Watcher; + my $watcher = Test2::Harness::Auditor::Watcher->new(job => 1, try => 0); + + require Test2::Harness::Event; + for my $e (@$events) { + my $fd = $e->facet_data; + my $he = Test2::Harness::Event->new( + facet_data => $fd, + event_id => gen_uuid(), + run_id => $run_id, + job_id => $job_id, + stamp => time, + job_try => 0, + ); + + $watcher->process($he); + } + + return { + plan => $watcher->plan, + pass => $watcher->pass ? 1 : 0, + fail => $watcher->fail ? 1 : 0, + errors => $watcher->_errors, + failures => $watcher->_failures, + assertions => $watcher->assertion_count, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::HarnessTester - Run events through a harness for a summary + +=head1 DESCRIPTION + +This tool allows you to process events through the L<Test2::Harness> auditor. +The main benefit here is to get a pass/fail result, as well as counts for +assertions, failures, and errors. + +=head1 SYNOPSIS + + use Test2::V0; + use Test2::API qw/intercept/; + use Test2::Tools::HarnessTester qw/summarize_events/; + + my $events = intercept { + ok(1, "pass"); + ok(2, "pass gain"); + done_testing; + }; + + is( + summarize_events($events), + { + # Each of these is the negation of the other, no need to check both + pass => 1, + fail => 0, + + # The plan facet, see Test2::EventFacet::Plan + plan => {count => 2}, + + # Statistics + assertions => 2, + errors => 0, + failures => 0, + } + ); + +=head1 EXPORTS + +=head2 $summary = summarize_events($events) + +This takes an arrayref of events, such as that produced by C<intercept {...}> +from L<Test2::API>. The result is a hashref that summarizes the results of the +events as processed by L<Test2::Harness>, specifically the +L<Test2::Harness::Auditor::Watcher> module. + +Fields in the summary hash: + +=over 4 + +=item pass => $BOOL + +=item fail => $BOOL + +These are negatives of eachother. These represent the pass/fail state after +processing the events. When one is true the other should be false. These are +normalized to C<1> and C<0>. + +=item plan => $HASHREF + +If a plan was provided this will have the L<Test2::EventFacet::Plan> facet, but +as a hashref, not a blessed instance. + +B<Note:> This is reference to the original data, not a copy, if you modify it +you will modify the event as well. + +=item assertions => $INT + +Count of assertions made. + +=item errors => $INT + +Count of errors seen. + +=item failures => $INT + +Count of failures seen. + +=back + +=head2 $path = make_example_dir() + +This will create a temporary directory with 't', 't2', and 'xt' subdirectories +each of which will contain a single passing test. + +This is re-exported from L<App::Yath::Tester>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/moreold/Base.pm b/moreold/Base.pm new file mode 100644 index 000000000..2c8a57a49 --- /dev/null +++ b/moreold/Base.pm @@ -0,0 +1,390 @@ +package Test2::Harness::Util::IPC::TxnState::Base; +use strict; +use warnings; + +use Carp qw/confess croak/; +use Fcntl qw/:flock/; +use Errno qw/EINTR EAGAIN/; +use Scalar::Util qw/weaken/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::File::JSON; + +sub STATE_FILE() { 0 } +sub STATE_MASK() { 1 } +sub META() { 2 } +sub DATA() { 3 } + +sub LOCAL() { 'LOCAL' } +sub SHARED() { 'shared' } + +sub read_only { $_[0]->[+META]->{read_only} } +sub set_read_only { $_[0]->[+META]->{read_only} = 1 } +sub state_file { $_[0]->[+STATE_FILE] } +sub state_mask { $_[0]->[+STATE_MASK] } +sub meta { $_[0]->[+META] //= {} } +sub data { $_[0]->[+DATA] or Carp::croak("Not inside a transaction") } + +sub verify_init_state { } +sub before_txn { } +sub after_txn { } + +sub new { + my $class = shift; + my ($state_file, %params) = @_; + + my $mask = $params{mask} // $params{state_mask} // 0007; + my $meta = $params{meta} //= {}; + my $data = $params{data}; + + my $self = bless([$state_file, $mask, $meta], $class); + + Carp::croak("Cannot set initial data in read-only instance") + if $data && $meta->{read_only}; + + if($data) { + $self->transaction(w => sub { + # Fail if the state file has data already + Carp::croak("Cannot initialize state data, state already has data!") + if grep { $_ ne LOCAL() } keys %{$self->[+DATA]}; + + %{$self->[+DATA]} = (%$data, %{$self->[+DATA]}); + + $self->verify_init_state($self->[+DATA]); + }); + } + + return $self; +} + +sub shared_types { {} } + +sub shared_all { + my $self = shift; + my (@types) = @_; + + my @out; + + my $shared_types = $self->shared_types or return \@out; + + @types = keys %$shared_types unless @types; + return \@out unless @types; + + $self->transaction(r => sub { + for my $type (@types) { + my @ids; + ($type, @ids) = @$type if ref $type; + my $spec = $shared_types->{$type}; + + if ($spec->{single}) { + confess "Passing in an ID ($ids[0]) makes no sense for type '$type'" if @ids; + my $inst = $self->shared_get($type); + push @out => $inst if $inst; + } + else { + @ids = (keys %{$self->[+DATA]->{+SHARED}->{$type} // {}}) unless @ids; + + for my $id1 (@ids) { + if($spec->{double}) { + for my $id2 (keys %{$self->[+DATA]->{+SHARED}->{$type}->{$id1} // {}}) { + my $inst = $self->shared_get($type, $id1, $id2); + push @out => $inst if $inst; + } + } + else { + my $inst = $self->shared_get($type, $id1); + push @out => $inst if $inst; + } + } + } + } + }); + + return \@out; +} + +sub shared_init { + my $self = shift; + my $type = shift; + my $spec = $self->shared_types->{$type} or croak "Invalid shared type '$type'"; + my $id1 = $spec->{single} ? undef : shift; + my $id2 = $spec->{double} ? shift : undef; + my %args = @_; + + my $handle = $self->shared_handle($type, $id1, $id2); + + my $class = $args{class} //= $spec->{class}; + require(mod2file($class)); + + confess "'$type' class '$class' is not a 'Test2::Harness::Util::IPC::TxnState::Shared'" + unless $class->isa('Test2::Harness::Util::IPC::TxnState::Shared'); + + my $inst; + $self->transaction(w => sub { + $inst = $class->new(%args, state => $self, state_field => [$type, $id1, $id2]); + my $mref = $handle->(+META); + my $dref = $handle->(+DATA); + + if ($$dref) { + my $path = join '->' => grep { $_ } $type, $id1, $id2; + confess "Shared instance of '$path' already initialized" + } + + $$dref = $inst; + $$mref = $inst; + weaken($$mref); + }); + + return $inst; +} + +my %KEY_LOOKUP = ( + meta => META(), + data => DATA(), +); + +sub shared_handle { + my $self = shift; + my ($type, $id1, $id2) = @_; + my $spec = $self->shared_types->{$type} or croak "Invalid shared type '$type'"; + + my $out = sub { + my ($key) = @_; + + $key = $KEY_LOOKUP{$key} // $key; + + my $parent = \($self->[$key]->{+SHARED}); + my $ref = \($self->[$key]->{+SHARED}->{$type}); + unless ($spec->{single}) { + $$ref //= {}; + + croak "type '$type' requires an ID" unless $id1; + $parent = $ref; + $ref = \(${$ref}->{$id1}); + + if ($spec->{double}) { + croak "type '$type' requires a second ID" unless $id2; + $$ref //= {}; + $parent = $ref; + $ref = \(${$ref}->{$id2}); + } + } + + return ($parent, $ref); + }; + + return $out; +} + +sub shared_delete { + my $self = shift; + my ($type, $id1, $id2) = @_; + + my $spec = $self->shared_types->{$type} or croak "Invalid shared type '$type'"; + my $handle = $self->shared_handle($type, $id1, $id2); + + ${$handle->(+META)} = undef; + + my $out; + $self->transaction( + w => sub { + for my $place (META(), DATA()) { + my ($parent, $ref) = $handle->($place); + + $spec->{on_delete}->($self, $type, $id1, $id2, $parent, $ref) if $spec->{on_delete} && $place == DATA(); + + if ($id2) { $out = delete ${$parent}->{$id2} } + elsif ($id1) { $out = delete ${$parent}->{$id1} } + else { $out = delete ${$parent}->{$type} } + } + } + ); + + return $out; +} + +sub shared_get { + my $self = shift; + my ($type, $id1, $id2) = @_; + my $handle = $self->shared_handle($type, $id1, $id2); + + my $inst; + if ($inst = ${$handle->(+META)}) { + $inst->refresh(); + return $inst; + } + + $self->transaction(r => sub { + my $ref = $handle->(+DATA); + my $data = $$ref or return; + + my $class = $data->{class}; + require(mod2file($class)); + + $inst = $class->from_data($data, $self, [$type, $id1, $id2]); + $self->[+META]->{+SHARED}->{$type} = $inst; + weaken($self->[+META]->{+SHARED}->{$type}); + }); + + return $inst if $inst; + + my $path = join '->' => grep { $_ } $type, $id1, $id2; + croak "shared '$path' is not initialized"; +} + +sub transaction { + my $self = shift; + my ($mode, $cb, @args) = @_; + + $self->transaction2( + mode => $mode, + callback => $cb, + args => \@args, + ); +} + +sub transaction2 { + my $self = shift; + my %params = @_; + + my $mode = $params{mode} // 'r'; + my $cb = $params{callback} // $params{cb}; + my $args = $params{args}; + + my $before_write = $params{before_write}; + my $after_write = $params{after_write}; + + my $write = $mode eq 'w' || $mode eq 'rw'; + my $read = $mode eq 'ro' || $mode eq 'r'; + Carp::croak("mode must be 'w', 'rw', 'r', or 'ro', got '$mode'") unless $write || $read; + + my ($lock, $state, $local, $new, $clear_local); + if ($state = $self->[+DATA]) { + $new = 0; + + $local = $state->{+LOCAL}; + $clear_local = 0; + + Carp::confess("Attempted to use a non-local state (Did you store a copy of a state then terminate the transaction?)") + unless $local; + + Carp::confess("Attempted a 'write' transaction inside of a read-only transaction") + if $write && !$local->{write}; + } + else { + $new = 1; + + my $oldmask = umask($self->[+STATE_MASK]); + my $ok = eval { + my $lockf = "$self->[+STATE_FILE].LOCK"; + + my $dir = $lockf; + $dir =~ s{[^/]+$}{}; + open($lock, ((-f $lockf) ? '>>' : '>'), $lockf) or die "Could not open lock file '$lockf': $!"; + while (1) { + last if flock($lock, $write ? LOCK_EX : LOCK_SH); + next if $! == EINTR || $! == EAGAIN; + warn "Could not get lock: $!"; + } + + $state = $self->_read_state(); + 1; + }; + my $err = $@; + umask($oldmask); + die $err unless $ok; + + $clear_local = 1; + $local = $state->{+LOCAL} = { + lock => $lock, + mode => $mode, + write => $write, + stack => [{cb => $cb, args => $args}], + }; + + weaken($state->{+LOCAL}->{lock}); + } + + local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => $args}]) + if $self->[+DATA]; + + local $self->[+DATA] = $state; + + my $out; + my $ok = eval { + $self->before_txn($cb, @$args) if $write; + $out = $cb ? $self->$cb(@$args) : $state; + $self->after_txn($cb, @$args) if $write; + 1; + }; + my $err = $@; + + if ($ok && $write && $new) { + $before_write->($state) if $before_write; + $self->_write_state($state); + $after_write->($state) if $after_write; + } + + if ($lock) { + unless (flock($lock, LOCK_UN)) { + my $prob = "Could not release lock: $!"; + $ok ? die $prob : warn $prob; + } + } + + die $err unless $ok; + + delete $state->{+LOCAL} if $clear_local; + + return $out; +} + +sub _read_state { + my $self = shift; + + return {} unless -e $self->[+STATE_FILE]; + + my $file = Test2::Harness::Util::File::JSON->new(name => $self->[+STATE_FILE]); + + my ($ok, $err, $state); + for (1 .. 10) { + $ok = eval { $state = $file->maybe_read(); 1 }; + $err = $@; + + last if $ok; + + sleep 0.1; + } + + die "Corrupted state? Error that caused this was:\n======\n$err\n======\n" + unless $ok; + + return $state; +} + +sub _write_state { + my $self = shift; + my ($state) = @_; + + my $state_copy = {%$state}; + + my $local = delete $state_copy->{+LOCAL}; + + Carp::confess("Attempted write with no lock") unless $local->{lock}; + Carp::confess("Attempted write with a read-only lock") unless $local->{write}; + + my $oldmask = umask($self->[+STATE_MASK]); + my $ok = eval { + my $file = Test2::Harness::Util::File::JSON->new(name => $self->[+STATE_FILE]); + $file->rewrite($state_copy); + 1; + }; + my $err = $@; + + umask($oldmask); + + die $err unless $ok; +} + +1; diff --git a/moreold/Shared.pm b/moreold/Shared.pm new file mode 100644 index 000000000..a32bb6a1f --- /dev/null +++ b/moreold/Shared.pm @@ -0,0 +1,238 @@ +package Test2::Harness::Util::IPC::TxnState::Shared; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak confess/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/mod2file/; +use Test2::Harness::Util::IPC qw/pid_is_running/; +use POSIX ":sys_wait_h"; + +use Test2::Harness::Util::HashBase qw{ <state <state_field <pid <ppid <cpid exit_code }; + +sub tag { undef } + +sub from_data { + my $class = shift; + my ($data, $state, $field, %params) = @_; + + $data->{+STATE} = $state; + $data->{+STATE_FIELD} = $field; + + my $self = bless($data, $class); + + $self->init() if delete $params{init}; + + $self->inflate(); + + return $self; +} + +sub inflate {} + +sub init { + my $self = shift; + croak "'state' is a required attribute" unless $self->{+STATE}; + croak "'state_field' is a required attribute" unless $self->{+STATE_FIELD}; +} + +sub refresh { + my $self = shift; + + my $state = $self->{+STATE}; + my $state_field = $self->{+STATE_FIELD}; + + $state->transaction(r => sub { + my $field = $self->field(); + my $data = $$field; + %$self = (%$self, %$data, state => $state, state_field => $state_field); + }); + + $self->inflate(); + + return $self; +} + +sub field { + my $self = shift; + + my $state = $self->{+STATE}; + my $state_field = $self->{+STATE_FIELD}; + + my $handle = $state->shared_handle(@$state_field); + return $handle->('data'); +} + +sub before_write {} +sub after_write {} + +sub transaction { + my $self = shift; + my ($mode, $cb) = @_; + + my $state = $self->{+STATE}; + my $state_field = $self->{+STATE_FIELD}; + + $state->transaction2( + mode => $mode, + before_write => sub { $self->before_write(@_) }, + after_write => sub { $self->after_write(@_) }, + callback => sub { + my $field = $self->field; + my $data = $$field; + %$self = (%$data, state => $state, state_field => $state_field); + $self->inflate; + $$field = $self; + + return $cb->(@_) if $cb; + }, + ); + + return $self; +} + +sub proc_name { + my $self = shift; + my $type = ref($self); + $type =~ s/^.*:://; + $type = lc($type); + + return "$0-$type"; +} + +sub spawn_collected { + my $self = shift; + my %params = @_; + + my $collector_params = delete $params{collector} // {}; + + my $cpid = fork // die "Could not fork: $!"; + if ($cpid) { + $self->transaction(w => sub { + $self->{+PPID} = $$; + $self->{+CPID} = $cpid; + }); + + return $cpid; + } + + my $ok = eval { + require Test2::Harness::Collector; + my $collector = Test2::Harness::Collector->new(%$collector_params); + + my $pid = $self->spawn(%params, collector => $collector); + + $0 = ($params{proc_name} || $self->proc_name) . '-collector'; + $collector->process($pid); + 1; + }; + my $err = $@; + + warn "Scope Leak"; + warn "error: $err" unless $ok; + exit 255; +} + +sub spawn { + my $self = shift; + my %params = @_; + + my $run_method = $params{run_method} // 'run'; + + croak "Cannot spawn from a read-only connection" + if $self->state->read_only; + + my $pid = fork // die "Could not fork: $!"; + if ($pid) { + $self->transaction(w => sub { + $self->{+PPID} //= $$; + $self->{+PID} = $pid; + }); + + return $pid; + } + + $0 = delete($params{proc_name}) || $self->proc_name; + + if (my $collector = delete $params{collector}) { + $collector->setup_child(); + } + + $SIG{TERM} = 'DEFAULT'; + $SIG{INT} = 'DEFAULT'; + + unless(eval { exit($self->$run_method(%params) // 0); 1 }) { + warn($@); + exit(255); + } + + confess("Escaped scope after spawned call to '$self->run()'"); + exit(255); +} + +sub is_my_child { + my $self = shift; + + return unless $$ == $self->{+PPID}; + return $self->{+CPID} // $self->{+PID} // confess "Proces not started"; +} + +sub wait { + my $self = shift; + my ($flags) = @_; + + $flags //= 0; + + confess "Not process parent" unless $$ == $self->{+PPID}; + my $pid = $self->{+CPID} || $self->{+PID} || confess "Proces not started"; + + local $?; + + my $check = waitpid($pid, $flags); + my $exit = $?; + if ($check == $pid) { + $self->{+EXIT_CODE} = $exit; + delete $self->{+CPID}; + delete $self->{+PID}; + delete $self->{+PPID}; + } + + return ($check, $exit); +} + +sub is_running { + my $self = shift; + return undef unless $self->{+PID}; + + if ($$ == $self->{+PPID}) { + my ($check) = $self->wait(WNOHANG); + return 0 if $check > 0; + } + + return 1 if $self->{+CPID} && pid_is_running($self->{+CPID}); + return 1 if $self->{+PID} && pid_is_running($self->{+PID}); + return 0; +} + +sub kill { + my $self = shift; + my ($sig) = @_; + + return 0 unless $self->is_running; + my $cnt = 0; + $cnt += kill($sig, $self->{+PID}) if $self->{+PID}; + $cnt += kill($sig, $self->{+CPID}) if $self->{+CPID}; + return $cnt; +} + +sub TO_JSON { + my $self = shift; + my %data = %$self; + delete $data{state}; + delete $data{state_field}; + return \%data; +} + +1; diff --git a/moreold/TxnState.pm b/moreold/TxnState.pm new file mode 100644 index 000000000..3444a11ee --- /dev/null +++ b/moreold/TxnState.pm @@ -0,0 +1,75 @@ +package Test2::Harness::Util::IPC::TxnState; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp(); +use Scalar::Util qw/weaken/; +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::Util::IPC::TxnState::Base; + +BEGIN { + for my $const (qw/STATE_FILE STATE_MASK META DATA LOCAL/) { + no strict 'refs'; + *$const = Test2::Harness::Util::IPC::TxnState::Base->can($const); + } +} + +use parent 'Test2::Harness::Util::HashBase'; + +sub do_import { + my $class = shift; + my $into = shift; + + { + no strict 'refs'; + push @{"$into\::ISA"} => 'Test2::Harness::Util::IPC::TxnState::Base'; + } + + $class->SUPER::do_import($into => @_); +} + +sub spec { + my $class = shift; + + return { + %{$class->SUPER::spec()}, + '~' => {custom => 1, strip => 1, shared => 1}, + }; +} + +sub gen_accessor { + my $class = shift; + my ($type, $attr, $spec, $args) = @_; + + if ($type eq 'custom' && $spec->{shared}) { + die "fixme"; # removing this concept. See the XXX file + return; + } + + return sub { + return $_[0]->[+DATA]->{$attr} if $_[0]->[+DATA]; + $_[0]->transaction('r' => sub { $_[0]->[+DATA]->{$attr} }); + } if $type eq 'reader'; + + return sub { + Carp::croak("Writer for '$attr' can only be used in a transaction") unless $_[0]->[+DATA]; + Carp::croak("Writer for '$attr' can only be used in a write transaction") unless $_[0]->[+DATA]->{+LOCAL}->{write}; + $_[0]->[+DATA]->{$attr} = $_[1]; + } if $type eq 'writer'; + + return sub { Carp::croak("'$attr' is read-only") } + if $type eq 'read_only'; + + return sub { + Carp::carp("set_$attr() is deprecated"); + Carp::croak("Accessor can only be used in a transaction") unless $_[0]->[+DATA]; + $_[0]->[+DATA]->{$attr} = $_[1]; + } if $type eq 'dep_writer'; + + Carp::croak("Invalid accessor type '$type' for attribute '$attr'"); +} + +1; diff --git a/release-scripts/generate_command_pod.pl b/release-scripts/generate_command_pod.pl index a88fc53af..2f580fe05 100755 --- a/release-scripts/generate_command_pod.pl +++ b/release-scripts/generate_command_pod.pl @@ -1,4 +1,6 @@ #!/usr/bin/env perl +use strict; +use warnings; die "No directory specified" unless @ARGV; chdir($ARGV[0]) or die "Could not chdir to $ARGV[0]"; @@ -22,7 +24,7 @@ require $rel; - my $pod = $pkg->generate_pod or die "Could not get usage POD!"; + my $pod = generate_pod($pkg) or die "Could not get usage POD!"; $pod = join "\n\n" => start(), $pod, ending(); @@ -47,6 +49,58 @@ close($fh); } +sub generate_pod { + my $class = shift; + + die "FIXME"; + + my $cmd = $class->name; + my (@args) = $class->doc_args; + + my $options = App::Yath::Options->new(); + require App::Yath; + my $ay = App::Yath->new(); + $options->include($ay->load_options); + $options->set_command_class($class); + my $pre_opts = $options->pre_docs('pod', head => 3); + my $cmd_opts = $options->cmd_docs('pod', head => 3); + + my $usage = " \$ yath [YATH OPTIONS] $cmd"; + + my @head2s; + + push @head2s => ("=head2 YATH OPTIONS", $pre_opts) if $pre_opts; + + if ($cmd_opts) { + $usage .= " [COMMAND OPTIONS]"; + push @head2s => ("=head2 COMMAND OPTIONS", $cmd_opts); + } + + if (@args) { + $usage .= " [COMMAND ARGUMENTS]"; + + push @head2s => ( + "=head2 COMMAND ARGUMENTS", + "=over 4", + (map { ref($_) ? ( "=item $_->[0]", $_->[1] ) : ("=item $_") } @args), + "=back" + ); + } + + my @out = ( + "=head1 NAME", + "$class - " . $class->summary, + "=head1 DESCRIPTION", + $class->description, + "=head1 USAGE", + $usage, + @head2s + ); + + return join("\n\n" => grep { $_ } @out); +} + + sub start { return ("=pod", "=encoding UTF-8"); } diff --git a/scripts/yath-stage b/scripts/yath-stage new file mode 100755 index 000000000..c6c6add43 --- /dev/null +++ b/scripts/yath-stage @@ -0,0 +1,330 @@ +#!/usr/bin/perl +# Do not use warnings/strict, we want to avoid contamination of the + +# '-D' and '--dev-lib' MUST be handled well in advance of loading ANYTHING. +# These will get re-processed later, but they MUST come even before App::Yath +# is loaded. +my ($OK, $ERR); +BEGIN { + local $.; + return if $^C; + + package App::Yath::Script; + + my %seen; + @INC = grep { !$seen{$_}++ } @INC; + + my $ORIG_TMP; + my $ORIG_TMP_PERMS; + my %ORIG_SIG = map { defined($SIG{$_}) ? ($_ => $SIG{$_}) : ()} keys %SIG; + my @ORIG_ARGV = @ARGV; + my @ORIG_INC = @INC; + my @DEVLIBS; + my %CONFIG; + my %SCAN; + + our $SCRIPT; + + # ==START TESTABLE CODE FIND_CONFIG_FILES== + + my ($config_file, $user_config_file); + + # Would be nice if we could use File::Spec, but we cannot load ANYTHING yet. + my %no_stat = (mswin32 => 1, vms => 1, riscos => 1, os2 => 1, cygwin => 1); + %seen = (); + my $dir = './'; + for (1 .. 100) { # If we are more than 100 deep we have other problems + if ($no_stat{lc($^O)}) { + opendir(my $dh, $dir) or die "$!"; + my $key = join ':' => sort readdir($dh); + last if $seen{$key}++; + } + else { + my ($dev, $ino) = stat $dir; + last if $seen{$dev}{$ino}++; + } + + $config_file //= "${dir}.yath.rc" if -f "${dir}.yath.rc"; + $user_config_file //= "${dir}.yath.user.rc" if -f "${dir}.yath.user.rc"; + + last if $config_file && $user_config_file; + + $dir .= "../"; + } + + # ==END TESTABLE CODE FIND_CONFIG_FILES== + # ==START TESTABLE CODE PARSE_CONFIG_FILES== + + my (@CONFIG_ARGS, @TO_CLEAN); + for my $file ($config_file, $user_config_file) { + next unless $file && -f $file; + + my $cmd; + open(my $fh, '<', $file) or die "Could not open config file '$file' for reading: $!"; + while (my $line = <$fh>) { + chomp($line); + $cmd = $1 and next if $line =~ m/^\[(.*)\]$/; + $line =~ s/;.*$//g; + $line =~ s/^\s*//g; + $line =~ s/\s*$//g; + next unless length($line); + + my ($key, $eq, $val); + if ($line =~ m/^(-\S)((?:rel|glob|relglob)\(.*\))$/) { # Handle things like -Irel(...) + $key = $1; + $eq = ''; + $val = $2; + } + else { + ($key, $eq, $val) = split /(=|\s+)/, $line, 2; # Covers most cases + } + + my $is_pre; + if ($key =~ m/^-D/ || $key eq '--dev-lib') { + $eq = '=' if $val; + $is_pre = 1; + } + + if ($key eq '--no-scan-plugins') { + $is_pre = 1; + } + + my $need_to_clean; + if ($val && $val =~ s/(^|=)\s*rel\(\s*//) { + die "Syntax error in $file line $.: Expected ')'\n" unless $val =~ s/\s*\)$//; + my $path = $file; + $path =~ s{[^/]*$}{}g; + $val = "${path}${val}"; + $need_to_clean = 1; + } + + my @all; + + if ($val && $val =~ s/(^|=)\s*(rel)?glob\(\s*//) { + my $rel = $2; + + die "Syntax error in $file line $.: Expected ')'\n" unless $val =~ s/\s*\)$//; + + my $path = ''; + if ($rel) { + $path = $file; + $path =~ s{[^/]*$}{}g; + } + + # Avoid loading File::Glob in this process... + my $out = `$^X -e 'print join "\\n" => glob("${path}${val}")'`; + my @vals = split /\n/, $out; + @all = map {[$key, $eq, $_, 1]} @vals; + } + else { + @all = ([$key, $eq, $val, $need_to_clean]); + } + + for my $set (@all) { + my ($key, $eq, $val, $need_to_clean) = @$set; + $eq //= ''; + + my @parts = $eq eq '=' ? ("${key}${eq}${val}") : (grep { defined $_ } $key, $val); + + if ($is_pre) { + push @CONFIG_ARGS => @parts; + } + else { + $cmd //= '~'; + push @{$CONFIG{$cmd}} => @parts; + push @TO_CLEAN => [$cmd, $#{$CONFIG{$cmd}}, $key, $eq, $val] if $need_to_clean; + } + } + } + close($fh); + } + + unshift @ARGV => @CONFIG_ARGS; + + # ==END TESTABLE CODE PARSE_CONFIG_FILES== + # ==START TESTABLE CODE PRE_PARSE_D_ARGS== + + my (@libs, %done, @args, $maybe_exec); + while (@ARGV) { + my $arg = shift @ARGV; + + if ($arg eq '--' || $arg eq '::') { + push @args => $arg; + last; + } + + if ($arg eq '-c' || $arg eq '--color') { + $ENV{YATH_COLOR} = 1; + } + elsif ($arg eq '--no-color') { + $ENV{YATH_COLOR} = 0; + } + + if ($arg eq '--no-dev-lib') { + @libs = (); + %done = (); + next; + } + + if ($arg =~ m{^(?:(?:-D=?|--dev-lib=)(.*)|--dev-lib)$}) { + my @add = $1 ? ($1) : (); + unless (@add) { + @add = ('lib', 'blib/lib', 'blib/arch'); + $maybe_exec = $arg; + } + + push @libs => grep { !$done{$_}++ } @add; + next; + } + + if ($arg =~ m/--(no-)?scan-([^=\{]+)$/) { + my $val = $1 ? 0 : 1; + $SCAN{$2} = $val; + next; + } + + push @args => $arg; + } + @ARGV = (@args, @ARGV); + + unshift @INC => @libs; + unshift @DEVLIBS => @libs; + + # ==END TESTABLE CODE PRE_PARSE_D_ARGS== + # ==START TESTABLE CODE EXEC== + + # Now it is safe/ok to load things. + require Cwd; + require File::Spec; + + $ORIG_TMP = File::Spec->tmpdir(); + $ORIG_TMP_PERMS = ((stat($ORIG_TMP))[2] & 07777); + $SCRIPT = Cwd::realpath(__FILE__) // File::Spec->rel2abs(__FILE__); + + if ($maybe_exec && -e 'scripts/yath') { + my $script = Cwd::realpath('scripts/yath') // File::Spec->rel2abs('scripts/yath'); + + if ($SCRIPT ne $script) { + warn "\n** $maybe_exec was used, and scripts/yath is present, using exec to switch to it. **\n\n"; + exec($script, @ORIG_ARGV); + die("Should not see this, exec failed!"); + } + } + + # ==END TESTABLE CODE EXEC== + # ==START TESTABLE CODE CLEANUP_PATHS== + + if (@libs || @TO_CLEAN) { + for (my $i = 0; $i < @libs; $i++) { + $DEVLIBS[$i] = $INC[$i] = Cwd::realpath($INC[$i]) // File::Spec->rel2abs($INC[$i]); + } + + for my $clean (@TO_CLEAN) { + my ($cmd, $idx, $key, $eq, $val) = @$clean; + $val = Cwd::realpath($val) // File::Spec->rel2abs($val); + + if ($eq eq '=') { + $CONFIG{$cmd}->[$idx] = "${key}${eq}${val}"; + } + else { + $CONFIG{$cmd}->[$idx] = $val; + } + } + } + + # ==END TESTABLE CODE CLEANUP_PATHS== + # ==START TESTABLE CODE CREATE_APP== + + require App::Yath; + require Time::HiRes; + require Getopt::Yath::Settings; + + my %mixin = (config_file => '', user_config_file => ''); + $mixin{config_file} = Cwd::realpath($config_file) // File::Spec->rel2abs($config_file) if $config_file; + $mixin{user_config_file} = Cwd::realpath($user_config_file) // File::Spec->rel2abs($user_config_file) if $user_config_file; + + my $settings = Getopt::Yath::Settings->new( + yath => { + orig_tmp => $ORIG_TMP, + orig_tmp_perms => $ORIG_TMP_PERMS, + orig_sig => \%ORIG_SIG, + orig_argv => \@ORIG_ARGV, + orig_inc => \@ORIG_INC, + script => $SCRIPT, + script_version => $App::Yath::VERSION, + dev_libs => \@DEVLIBS, + start => Time::HiRes::time(), + cwd => Cwd::getcwd(), + scan_options => \%SCAN, + %mixin, + }, + ); + + my $app = App::Yath->new( + argv => \@ARGV, + config => \%CONFIG, + settings => $settings, + ); + + $OK = eval { $app->generate_run_sub('App::Yath::Script::run'); 1 }; + $ERR = $@; + + # ==END TESTABLE CODE CREATE_APP== +} + +die $ERR unless $OK; + +# Reset these if we got this far. +$? = 0; +$@ = ''; + +exit(App::Yath::Script::run()); + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +yath - Primary Command Line Interface (CLI) for Test2::Harness + +=head1 DESCRIPTION + +This is the primary command line interface for App::Yath/Test2::Harness. Yath +is essentially a shell around the components of L<Test2::Harness>. +For usage instructions and examples, +see L<App::Yath>. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/t/HashBase.t b/t/HashBase.t index 2096e0462..8dc020eae 100644 --- a/t/HashBase.t +++ b/t/HashBase.t @@ -3,6 +3,7 @@ use warnings; use Test::More; + sub warnings(&) { my $code = shift; my @warnings; @@ -82,7 +83,10 @@ is($pkg->do_it, 'const', "worked as expected"); *main::Const::Test::FOO = sub { 0 }; } ok(!$pkg->FOO, "overrode const sub"); +{ +local $TODO = "known to fail on $]" if $] le "5.006002"; is($pkg->do_it, 'const', "worked as expected, const was constant"); +} BEGIN { $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__; diff --git a/t/acceptence/getopt_yath.t b/t/acceptence/getopt_yath.t new file mode 100644 index 000000000..ed4a71793 --- /dev/null +++ b/t/acceptence/getopt_yath.t @@ -0,0 +1,797 @@ +use Test2::V0 -target => 'Getopt::Yath'; + +use Getopt::Yath; + +imported_ok qw/options option include_options option_post_process option_group parse_options/; + +delete $ENV{EXAMPLEA}; +delete $ENV{EXAMPLEB}; +delete $ENV{EXAMPLEC}; + +option_group {category => 'This is the category', group => 'foo', no_module => 1} => sub { + like( + dies { parse_options(['--xyz']) }, + qr/'--xyz' is not a valid option\./, + "Cannot use an invalid option", + ); + + ok( + lives { parse_options(['--xyz'], skip_invalid_opts => 1) }, + "Skip invalid", + ); + + subtest Bool => sub { + my $trigger = 0; + option foo => ( + type => 'Bool', + short => 'f', + default => 1, + description => 'foo boolean', + trigger => sub { $trigger++ } + ); + like( + parse_options([]), + {settings => {foo => {foo => 1}}}, + "A bool with a default of 1 and nothing provided" + ); + is($trigger, 0, "Not triggered"); $trigger = 0; + like( + parse_options(['--foo']), + {settings => {foo => {foo => 1}}}, + "Parsed a bool with a default of 1 turned on" + ); + is($trigger, 1, "triggered"); $trigger = 0; + like( + parse_options(['-f']), + {settings => {foo => {foo => 1}}}, + "Parsed a bool with a default of 1 turned on" + ); + is($trigger, 1, "triggered"); $trigger = 0; + like( + dies { parse_options(['-f=0']) }, + qr/Use of 'arg=val' form is not allowed in option '-f=0'\. Arguments are not allowed for this option type\./, + "Boolean types do not allow an argument" + ); + is($trigger, 0, "not triggered"); $trigger = 0; + like( + parse_options(['--no-foo']), + {settings => {foo => {foo => 0}}}, + "Parsed a bool with a default of 1 turned off" + ); + is($trigger, 1, "triggered"); $trigger = 0; + + option bar => ( + type => 'Bool', + default => 0, + description => 'bar boolean', + ); + like( + parse_options([]), + {settings => {foo => {bar => 0}}}, + "A bool with a default of 0 and nothing provided" + ); + like( + parse_options(['--bar']), + {settings => {foo => {bar => 1}}}, + "Parsed a bool with a default of 0 turned on" + ); + like( + parse_options(['--no-bar']), + {settings => {foo => {bar => 0}}}, + "Parsed a bool with a default of 0 turned off" + ); + + option baz => ( + type => 'Bool', + description => 'baz boolean', + ); + like( + parse_options([]), + {settings => {foo => {baz => 0}}}, + "A bool with no default and nothing provided" + ); + like( + parse_options(['--baz']), + {settings => {foo => {baz => 1}}}, + "Parsed a bool with no default, turned on" + ); + like( + parse_options(['--no-baz']), + {settings => {foo => {baz => 0}}}, + "Parsed a bool with no default, turned off" + ); + }; + + subtest Count => sub { + option cnt => ( + type => 'Count', + short => 'c', + alt => ['count'], + initialize => 2, + description => 'A counter', + ); + like( + parse_options([]), + {settings => {foo => {cnt => 2}}}, + "Nothing provided, initialized to 2" + ); + like( + parse_options(['--no-count']), + {settings => {foo => {cnt => 0}}}, + "disabled via --no-count" + ); + like( + parse_options(['--no-count', '-ccc']), + {settings => {foo => {cnt => 3}}}, + "disabled via --no-count, but then seen 3 times as short value" + ); + + like( + parse_options(['--no-count', '-cc', '-c=-1']), + {settings => {foo => {cnt => -1}}}, + "disabled via --no-count, but then seen 2 times as short value, but last one sets a specific value" + ); + + like( + parse_options(['-c=5', '--count', '-c']), + {settings => {foo => {cnt => 7}}}, + "Set a value, then add 2 more" + ); + + like( + parse_options(['-c=0']), + {settings => {foo => {cnt => 0}}}, + "Set to 0" + ); + }; + + subtest Scalar => sub { + option scl => ( + type => 'Scalar', + short => 's', + alt => ['scalar'], + default => 'I am a scalar', + description => 'A scalar', + ); + + like( + parse_options([]), + {settings => {foo => {scl => 'I am a scalar'}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-s' => 'foo']), + {settings => {foo => {scl => 'foo'}}}, + "set to foo, short form" + ); + like( + parse_options(['-s=foo']), + {settings => {foo => {scl => 'foo'}}}, + "set to foo, short assign form" + ); + like( + parse_options(['--scl' => 'foo']), + {settings => {foo => {scl => 'foo'}}}, + "set to foo, long form" + ); + like( + parse_options(['--scalar=foo']), + {settings => {foo => {scl => 'foo'}}}, + "set to foo, long assign form" + ); + like( + dies { parse_options(['--scalar']) }, + qr/No argument provided to '--scalar'\./, + "Need a value" + ); + like( + parse_options(['--no-scalar']), + {settings => {foo => {scl => undef}}}, + "Disabled" + ); + + option scl2 => ( + type => 'Scalar', + description => 'Another scalar', + ); + like( + parse_options([]), + {settings => {foo => {scl2 => undef}}}, + "Nothing provided, default to undef" + ); + }; + + subtest Auto => sub { + option aut => ( + type => 'Auto', + short => 'a', + alt => ['auto'], + autofill => 'xxx', + default => 'yyy', + description => 'An auto-field', + ); + + like( + parse_options([]), + {settings => {foo => {aut => 'yyy'}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-a']), + {settings => {foo => {aut => 'xxx'}}}, + "Short with no arg, use autofill" + ); + like( + parse_options(['-afub']), + {settings => {foo => {aut => 'fub'}}}, + "Short with arg, no space and no =" + ); + like( + parse_options(['-a=foo']), + {settings => {foo => {aut => 'foo'}}}, + "Short with arg" + ); + like( + parse_options(['--no-aut']), + {settings => {foo => {aut => undef}}}, + "--no form" + ); + like( + parse_options(['--aut', 'foo'], skip_non_opts => 1), + {settings => {foo => {aut => 'xxx'}}, skipped => ['foo']}, + "Does not slurp next arg" + ); + + option aut2 => ( type => 'Auto', autofill => 'zzz' ); + like( + parse_options([]), + {settings => {foo => {aut2 => undef}}}, + "Nothing provided" + ); + + like( + dies { option aut3 => ( type => 'Auto' ) }, + qr/'autofill' is required/, + "autofill is required for auto type" + ); + }; + + subtest Map => sub { + option map => ( + type => 'Map', + short => 'm', + default => sub { 'yyy' => 'xxx' }, + split_on => ',', + description => 'A map', + ); + like( + parse_options([]), + {settings => {foo => {map => {'yyy' => 'xxx'}}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-m' => 'foo=bar']), + {settings => {foo => {map => {'foo' => 'bar'}}}}, + "Specified a value" + ); + like( + parse_options(['-m=foo=bar']), + {settings => {foo => {map => {'foo' => 'bar'}}}}, + "Specified a value with =" + ); + like( + parse_options(['-mfoo=bar']), + {settings => {foo => {map => {'foo' => 'bar'}}}}, + "Specified a value with no gap" + ); + like( + parse_options(['-m' => 'foo=bar,baz=bat', '--map' => 'fruit=pear']), + {settings => {foo => {map => {'foo' => 'bar', 'baz' => 'bat', 'fruit' => 'pear'}}}}, + "Specified multiple values" + ); + like( + parse_options(['--no-map']), + {settings => {foo => {map => {}}}}, + "Cleared values" + ); + }; + + subtest AutoMap => sub { + option auto_map => ( + type => 'AutoMap', + short => 'A', + autofill => sub { 'aaa' => 'bbb' }, + default => sub { 'yyy' => 'xxx' }, + split_on => ',', + description => 'An Auto map', + ); + like( + parse_options([]), + {settings => {foo => {auto_map => {'yyy' => 'xxx'}}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-A']), + {settings => {foo => {auto_map => {'aaa' => 'bbb'}}}}, + "Option, but no value, autofill" + ); + like( + parse_options(['-A=foo=bar']), + {settings => {foo => {auto_map => {'foo' => 'bar'}}}}, + "Specified a value" + ); + like( + dies { parse_options(['-A', 'foo=bar']) }, + qr/'foo=bar' is not a valid option\./, + "Do not slurp value after space" + ); + like( + parse_options(['-A=foo=bar,baz=bat', '--auto-map=fruit=pear']), + {settings => {foo => {auto_map => {'foo' => 'bar', 'baz' => 'bat', 'fruit' => 'pear'}}}}, + "Specified multiple values" + ); + like( + parse_options(['--no-auto-map']), + {settings => {foo => {auto_map => {}}}}, + "Cleared values" + ); + }; + + subtest List => sub { + option list => ( + type => 'List', + short => 'l', + default => sub { qw/foo bar baz/ }, + split_on => ',', + description => 'a list', + ); + like( + parse_options([]), + {settings => {foo => {list => [qw/foo bar baz/]}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-l' => 'xxx']), + {settings => {foo => {list => ['xxx']}}}, + "Specified a value" + ); + like( + parse_options(['-l' => 'xxx,yyy,baz,bat', '--list' => 'fruit,pear', '-l=bob']), + {settings => {foo => {list => ['xxx', 'yyy', 'baz', 'bat', 'fruit','pear','bob']}}}, + "Specified multiple values" + ); + like( + parse_options(['--no-list']), + {settings => {foo => {list => []}}}, + "Cleared values" + ); + }; + + subtest AutoList => sub { + option auto_list => ( + type => 'AutoList', + short => 'L', + default => sub { qw/foo bar baz/ }, + autofill => sub { qw/xxx yyy zzz/ }, + split_on => ',', + description => 'an auto list', + ); + like( + parse_options([]), + {settings => {foo => {auto_list => [qw/foo bar baz/]}}}, + "Nothing provided, default used" + ); + like( + parse_options(['-L']), + {settings => {foo => {auto_list => [qw/xxx yyy zzz/]}}}, + "Provided, but no value, use autofill" + ); + like( + parse_options(['-L=xxx']), + {settings => {foo => {auto_list => ['xxx']}}}, + "Specified a value" + ); + like( + parse_options(['-L=xxx,yyy,baz,bat', '--auto-list=fruit,pear']), + {settings => {foo => {auto_list => ['xxx', 'yyy', 'baz', 'bat', 'fruit','pear']}}}, + "Specified multiple values" + ); + like( + parse_options(['--no-auto-list']), + {settings => {foo => {auto_list => []}}}, + "Cleared values" + ); + like( + dies { parse_options(['-L', 'foo']) }, + qr/'foo' is not a valid option\./, + "Do not slurp value after space" + ); + }; + + subtest stop => sub { + my $res = parse_options(['-f', '-L', '--', "-m" => 'do_not=parse', "extra"], stops => ['::', '--'], skip_non_opts => 1); + like( + $res, + {'skipped' => [], 'stop' => '--', 'remains' => ['-m', 'do_not=parse', 'extra']}, + "Stopped at '--', got remaining args", + ); + }; + + subtest env => sub { + option env => ( + type => 'Scalar', + from_env_vars => [qw/EXAMPLEA EXAMPLEB EXAMPLEC/], + clear_env_vars => ['EXAMPLEA'], + set_env_vars => ['EXAMPLEC'], + ); + + local $ENV{EXAMPLEA} = "A"; + local $ENV{EXAMPLEB} = "B"; + local $ENV{EXAMPLEC} = "C"; + like( + parse_options([]), + {settings => {foo => {env => 'A'}}, env => {EXAMPLEA => undef, EXAMPLEC => 'A'}}, + "Set by env var" + ); + ok(!$ENV{EXAMPLEA}, "Clear env EXAMPLEA"); + is($ENV{EXAMPLEC}, 'A', "Set EXAMPLEC"); + + like( + parse_options([]), + {settings => {foo => {env => 'B'}}, env => {EXAMPLEA => undef, EXAMPLEC => 'B'}}, + "Set by another env var" + ); + is($ENV{EXAMPLEC}, 'B', "Set EXAMPLEC"); + }; + + subtest env_neg => sub { + option env_neg => ( + type => 'Scalar', + from_env_vars => [qw/!EXAMPLEA/], + clear_env_vars => ['EXAMPLEA'], + set_env_vars => ['!EXAMPLEX'], + ); + + local $ENV{EXAMPLEA} = 1; + local $ENV{EXAMPLEX}; + like( + parse_options([]), + {settings => {foo => {env_neg => F()}}, env => {EXAMPLEA => undef, EXAMPLEX => F()}}, + "Set by env var" + ); + ok(!$ENV{EXAMPLEA}, "Clear env EXAMPLEA"); + is($ENV{EXAMPLEX}, F(), "Set EXAMPLEX"); + + local $ENV{EXAMPLEA} = 0; + local $ENV{EXAMPLEX}; + like( + parse_options([]), + {settings => {foo => {env_neg => T()}}, env => {EXAMPLEA => undef, EXAMPLEX => T()}}, + "Set by env var" + ); + ok(!$ENV{EXAMPLEA}, "Clear env EXAMPLEA"); + is($ENV{EXAMPLEX}, T(), "Set EXAMPLEX"); + + }; + + + subtest post => sub { + my @order; + + option_post_process(sub { push @order => 'A' }); + option_post_process(-5 => sub { push @order => 'B' }); + option_post_process(5 => sub { push @order => 'C' }); + option_post_process(5 => sub { + my ($options, $state) = @_; + push @order => 'D'; + like( + $state, + { + cleared => {}, + env => {}, + remains => [], + settings => {}, + skipped => [], + }, + "State was passed in", + ); + }); + parse_options([]); + is(\@order, [qw/B A C D/], "Callbacks ran in order"); + }; + + subtest cli_docs => sub { + local $ENV{TABLE_TERM_SIZE} = 120; + is(options->docs('cli'), <<" EOT", "Got expected docs"); + +This is the category + --aut, --aut ARG, --aut=ARG, --auto, --auto ARG, --auto=ARG, -a, -aARG, -a ARG, -a=ARG + --no-aut + An auto-field + + --aut2, --aut2 ARG, --aut2=ARG, --no-aut2 + NO DESCRIPTION - FIX ME + + --auto-list, --auto-list ARG, --auto-list=ARG, -L, -LARG, -L ARG, -L=ARG, --no-auto-list + an auto list + + Note: Can be specified multiple times + + --auto-map, --auto-map=key=val, -A, -Akey=val, -A=key=val, --no-auto-map + An Auto map + + Note: Can be specified multiple times + + --bar, --no-bar + bar boolean + + --baz, --no-baz + baz boolean + + --cnt, --cnt=COUNT, --count, --count=COUNT, -c, -cc, -ccc.., -c=COUNT, --no-cnt + A counter + + Note: Can be specified multiple times, counter bumps each time it is used. + + --env ARG, --env=ARG, --no-env + NO DESCRIPTION - FIX ME + + Can also be set with the following environment variables: EXAMPLEA, EXAMPLEB, EXAMPLEC + + The following environment variables will be cleared after arguments are processed: EXAMPLEA + + The following environment variables will be set after arguments are processed: EXAMPLEC + + --foo, -f, --no-foo + foo boolean + + --list ARG, --list=ARG, -lARG, -l ARG, -l=ARG, --no-list + a list + + Note: Can be specified multiple times + + --map key=val, --map=key=val, -m key=val, -mkey=value, -m=key=val, --no-map + A map + + Note: Can be specified multiple times + + --scl ARG, --scl=ARG, --scalar ARG, --scalar=ARG, -sARG, -s ARG, -s=ARG, --no-scl + A scalar + + --scl2 ARG, --scl2=ARG, --no-scl2 + Another scalar + EOT + }; + + + subtest cli_docs => sub { + local $ENV{TABLE_TERM_SIZE} = 120; + is(options->docs('pod', groups => {':{' => '}:'}, category => 'foo', head => 3), <<" EOT", "Got expected docs"); +=head3 This is the category + +=over 4 + +=item --aut + +=item --aut ARG + +=item --aut=ARG + +=item --auto + +=item --auto ARG + +=item --auto=ARG + +=item -a + +=item -aARG + +=item -a ARG + +=item -a=ARG + +=item --no-aut + +An auto-field + + +=item --aut2 + +=item --aut2 ARG + +=item --aut2=ARG + +=item --no-aut2 + +NO DESCRIPTION - FIX ME + + +=item --auto-list + +=item --auto-list ARG + +=item --auto-list=ARG + +=item -L + +=item -LARG + +=item -L ARG + +=item -L=ARG + +=item --no-auto-list + +an auto list + +Can be specified multiple times + + +=item --auto-map + +=item --auto-map=key=val + +=item -A + +=item -Akey=val + +=item -A=key=val + +=item --no-auto-map + +An Auto map + +Can be specified multiple times + + +=item --bar + +=item --no-bar + +bar boolean + + +=item --baz + +=item --no-baz + +baz boolean + + +=item --cnt + +=item --cnt=COUNT + +=item --count + +=item --count=COUNT + +=item -c + +=item -cc + +=item -ccc.. + +=item -c=COUNT + +=item --no-cnt + +A counter + +Can be specified multiple times, counter bumps each time it is used. + + +=item --env ARG + +=item --env=ARG + +=item --no-env + +NO DESCRIPTION - FIX ME + +Can also be set with the following environment variables: C<EXAMPLEA>, C<EXAMPLEB>, C<EXAMPLEC> + +The following environment variables will be cleared after arguments are processed: C<EXAMPLEA> + +The following environment variables will be set after arguments are processed: C<EXAMPLEC> + + +=item --foo + +=item -f + +=item --no-foo + +foo boolean + + +=item --list ARG + +=item --list=ARG + +=item -lARG + +=item -l ARG + +=item -l=ARG + +=item --no-list + +a list + +Can be specified multiple times + + +=item --map key=val + +=item --map=key=val + +=item -m key=val + +=item -mkey=value + +=item -m=key=val + +=item --no-map + +A map + +Can be specified multiple times + + +=item --scl ARG + +=item --scl=ARG + +=item --scalar ARG + +=item --scalar=ARG + +=item -sARG + +=item -s ARG + +=item -s=ARG + +=item --no-scl + +A scalar + + +=item --scl2 ARG + +=item --scl2=ARG + +=item --no-scl2 + +Another scalar + + +=back + EOT + }; + + subtest modules => sub { + package Foo::Bar; + main::option_group({no_module => 0} => sub { + package main; + + option(mod => (type => 'Bool')); + + like( + parse_options(['--mod']), + {modules => {'Foo::Bar' => 1}}, + "Option got package name when no_module is not set, and we bumped it when we used the flag from it" + ); + + like( + parse_options([]), + {modules => in_set({'Foo::Bar' => FDNE()}, FDNE())}, + "Did not set module as used" + ); + }); + }; +}; + +done_testing; diff --git a/t/acceptence/ipc_statefile.t b/t/acceptence/ipc_statefile.t new file mode 100644 index 000000000..20a560ce1 --- /dev/null +++ b/t/acceptence/ipc_statefile.t @@ -0,0 +1,335 @@ +use Test2::V0 -target => 'IPC::StateFile'; +use Test2::IPC; +use File::Temp qw/tempdir/; + +my $dir = tempdir('ipcstatefiletest-XXXXXX', TMPDIR => 1, CLEANUP => 1); + +{ + package MyState; + $INC{'MyState.pm'} = __FILE__; + use parent 'IPC::StateFile'; + use Test2::Harness::Util::HashBase qw/xyz/; + + sub object_map { + return { + raw_data => {shared => 1, depth => 0}, + blessed_data => {shared => 1, depth => 0}, + + single_rpc => {rpc => 1, depth => 0}, + multi_rpc => {rpc => 1, depth => 1}, + deep_rpc => {rpc => 1, depth => 2}, + + single_proc => {rpc => 1, process => 1, depth => 0}, + }; + } + + package MyRPC; + $INC{'MyRPC.pm'} = __FILE__; + use parent 'IPC::StateFile::RPCObject'; + use Test2::Harness::Util::HashBase qw/foo bar/; + + sub shared_fields { +{ baz => 1, bat => 1, counter => 1 } } + + sub increment { + my $self = shift; + $self->txn(w => sub { + $self->set_field(counter => (1 + $self->get_field('counter') // 0)); + }); + } + + package MyProc; + $INC{'MyProc.pm'} = __FILE__; + use parent 'IPC::StateFile::RPCObject::Process'; + use Test2::Harness::Util::HashBase; + use Time::HiRes qw/sleep/; + + sub shared_fields { +{ %{shift->SUPER::shared_fields()}, counter => 1 } } + + sub run { + my $self = shift; + for (1 .. 10) { + $self->txn(w => sub { + $self->set_field(counter => 1 + $self->get_field('counter')); + }); + sleep(0.2); + } + } + + package MyNonRPC; + $INC{'MyNonRPC.pm'} = __FILE__; + use Test2::Harness::Util::HashBase qw/foo bar/; + sub TO_JSON { +{ %{$_[0]} } } + sub FROM_JSON { bless($_[1], $_[0]) } +} + +my $fname = "$dir/a"; + +my $one = MyState->create($fname); +isa_ok($one, CLASS()); + +like( + dies { MyState->create($fname) }, + qr/State file already exists/, + "Cannot create it twice" +); + +my $two = MyState->connect($fname); +isa_ok($two, CLASS()); + +subtest write_lock_blocks_read_lock => sub { + $one->txn( + w => sub { + my $ran = 0; + + ok(!$two->transaction(mode => 'r', blocking => 0, cb => sub { $ran++; 1 }), "Did not run"); + + ok(!$ran, "Did not run"); + } + ); +}; + +subtest nonblocking_read_lock_works => sub { + my $ran = 0; + + ok($two->transaction(mode => 'r', blocking => 0, cb => sub { $ran++; 1 }), "Ran"); + + ok($ran, "Did run"); +}; + +subtest write_hooks => sub { + my ($before, $after); + $one->set_before_write(sub { $before = 1 }); + $one->set_after_write(sub { $before = 1 }); + $one->txn(w => sub { 1 }); + ok($before, "Ran before hook"); + ok($before, "Ran after hook"); +}; + +subtest invalid_types => sub { + like( + dies { $one->set('foo', 1) }, + qr/Unsupported type 'foo'/, + "Not a valid type for set" + ); + + like( + dies { $one->init('foo', 1) }, + qr/Unsupported type 'foo'/, + "not a valid type for init" + ); + + like( + dies { $one->get('foo') }, + qr/Unsupported type 'foo'/, + "Not a valid type for get" + ); + + like( + dies { $one->del('foo') }, + qr/Unsupported type 'foo'/, + "Not a valid type for del" + ); + + like( + dies { $one->list('foo') }, + qr/Unsupported type 'foo'/, + "Not a valid type for list" + ); +}; + +subtest non_rpc_shared_data => sub { + $one->set(raw_data => {a => {b => 'c'}}); + is($one->get('raw_data'), {a => {b => 'c'}}, "Got value in connection 1"); + is($two->get('raw_data'), {a => {b => 'c'}}, "Got value in connection 2"); + + ref_is_not($two->get('raw_data'), $two->get('raw_data'), "No cache in this situation"); + + my ($ref1, $ref2); + $two->txn( + r => sub { + $ref1 = $two->get('raw_data'); + $ref2 = $two->get('raw_data'); + ref_is($ref1, $ref2, "Cached inside txn"); + } + ); + + ref_is_not($two->get('raw_data'), $ref1, "Cache expired after txn"); + + $one->txn(w => sub { $one->get('raw_data')->{x} = 1 }); + is($two->get('raw_data')->{x}, 1, "Got updated data"); + + like ( + dies { $one->set(single_rpc => 1) }, + qr/'single_rpc' is not a shared object/, + "Incorrect type cannot be used in set" + ); + + my @list = $one->list('raw_data'); + is(@list, 1, "Got 1 item"); + is(\@list, [{a => {b => 'c'}, x => 1}], "Got item in list"); + + $one->del('raw_data'); + ok(!$two->get('raw_data'), "Deleted"); + + my $fname2 = "$dir/b"; + my $three = MyState->create($fname2, raw_data => {foo => 1}, xyz => 123); + is($three->xyz, 123, "set xyz at creation"); + is($three->get('raw_data'), {foo => 1}, "set raw_data at creation"); + + my $four = MyState->connect($fname2, xyz => 345); + is($four->xyz, 345, "set xyz at creation"); + is($four->get('raw_data'), {foo => 1}, "got raw_data from creation"); +}; + +subtest blessed_non_rpc_shared => sub { + my $thing = MyNonRPC->new(foo => 'f1', bar => 'b1'); + $one->set(blessed_data => $thing); + my $copy = $two->get('blessed_data'); + is($copy, $thing, "Copied data"); + isa_ok($copy, 'MyNonRPC'); + + $one->txn(w => sub { $one->get('blessed_data')->set_foo('f2') }); + is($two->get('blessed_data')->foo, 'f2', "Got updated data"); + + my ($ref1, $ref2); + $two->txn( + r => sub { + $ref1 = $two->get('blessed_data'); + $ref2 = $two->get('blessed_data'); + ref_is($ref1, $ref2, "Cached inside txn"); + } + ); + + ref_is_not($two->get('blessed_data'), $ref1, "Cache expired after txn"); + + my @list = $one->list('blessed_data'); + is(@list, 1, "Got 1 item"); + is(\@list, [$ref1], "Got item in list"); + + $one->del('blessed_data'); + ok(!$two->get('blessed_data'), "Deleted"); +}; + +sub run_fork(&) { + my ($code) = @_; + my $pid = fork // die "Could not fork: $!"; + return $pid if $pid; + exit(0) if eval { $code->(); 1 }; + warn $@; + exit(255); +} + +subtest single_rpc => sub { + my $rpc1_1 = $one->init('single_rpc', MyRPC => {foo => 'f1', bar => 'br1', baz => 'bz1', bat => 'bt1', counter => 0}); + ref_is($one->get('single_rpc'), $rpc1_1, "Cached the reference, even outside of a txn"); + my $rpc2_1 = $two->get('single_rpc'); + ref_is($two->get('single_rpc'), $rpc2_1, "Cached the reference, even outside of a txn"); + + is($rpc2_1->get_field('baz'), 'bz1', "Got shared data"); + isnt($rpc2_1->foo, 'f1', "Did not share fields that are not shared"); + + my @pids; + push @pids => run_fork { $rpc1_1->increment } for 1 .. 10; + push @pids => run_fork { $rpc2_1->increment } for 1 .. 10; + waitpid($_, 0) for @pids; + is($rpc1_1->get_field('counter'), 20, "Incrementing in both objects effects both objects across 20 concurrent processes"); + is($rpc2_1->get_field('counter'), 20, "Incrementing in both objects effects both objects across 20 concurrent processes"); + + my @list = $one->list('single_rpc'); + is(@list, 1, "Got 1 item"); + + $one->del('single_rpc'); + is($two->list('single_rpc'), 0, "Deleted (list)"); + ok(!$two->get('single_rpc'), "Deleted (get)"); +}; + +subtest multi_rpc => sub { + my $rpc1_A = $one->init('multi_rpc', 'A', MyRPC => {baz => 'bz1', bat => 'bt1', counter => 0}); + ref_is($one->get('multi_rpc', 'A'), $rpc1_A, "Cached the reference, even outside of a txn"); + my $rpc2_A = $two->get('multi_rpc', 'A'); + ref_is($two->get('multi_rpc', 'A'), $rpc2_A, "Cached the reference, even outside of a txn"); + + my $rpc2_B = $two->init('multi_rpc', 'B', MyRPC => {baz => 'bz2', bat => 'bt2', counter => 0}); + my $rpc1_B = $one->get('multi_rpc', 'B'); + + is($rpc2_A->get_field('baz'), 'bz1', "Got shared data"); + is($rpc1_B->get_field('baz'), 'bz2', "Got shared data"); + + my @list = $one->list('multi_rpc'); + is(@list, 2, "Got 2 items"); + + $one->del('multi_rpc', 'A'); + is($two->list('multi_rpc'), 1, "Deleted A (list)"); + ok(!$two->get('multi_rpc', 'A'), "Deleted A (get)"); + + $one->del('multi_rpc'); + is($two->list('multi_rpc'), 0, "Deleted B (list)"); + ok(!$two->get('multi_rpc', 'B'), "Deleted B (get)"); +}; + +subtest deep_rpc => sub { + my $rpc1_A = $one->init('deep_rpc', 'x', 'A', MyRPC => {baz => 'bz1', bat => 'bt1', counter => 0}); + ref_is($one->get('deep_rpc', 'x', 'A'), $rpc1_A, "Cached the reference, even outside of a txn"); + my $rpc2_A = $two->get('deep_rpc', 'x', 'A'); + ref_is($two->get('deep_rpc', 'x', 'A'), $rpc2_A, "Cached the reference, even outside of a txn"); + + my $rpc2_B = $two->init('deep_rpc', 'x', 'B', MyRPC => {baz => 'bz2', bat => 'bt2', counter => 0}); + my $rpc1_B = $one->get('deep_rpc', 'x', 'B'); + + is($rpc2_A->get_field('baz'), 'bz1', "Got shared data"); + is($rpc1_B->get_field('baz'), 'bz2', "Got shared data"); + + my @list = $one->list('deep_rpc'); + is(@list, 2, "Got 2 items"); + + $one->del('deep_rpc', 'x', 'A'); + is($two->list('deep_rpc'), 1, "Deleted A (list)"); + ok(!$two->get('deep_rpc', 'x', 'A'), "Deleted A (get)"); + + $one->del('deep_rpc'); + is($two->list('deep_rpc'), 0, "Deleted B (list)"); + ok(!$two->get('deep_rpc', 'x', 'B'), "Deleted B (get)"); +}; + +subtest proc => sub { + my $proc1a = $one->init('single_proc', MyProc => {counter => 0}); + is($proc1a->get_field('counter'), 0, "Set to 0"); + ok($proc1a->spawn(), "Started"); + + my $pid = run_fork { + subtest proc_part2 => sub { + my $proc1b = $two->get('single_proc'); + like( + dies { $proc1b->spawn() }, + qr/Process is already running/, + "Already started" + ); + + ok($proc1b->is_running, "Running check"); + + like( + dies { $proc1b->wait }, + qr/Not process parent/, + "Not the momma!" + ); + + while ($proc1b->is_running) { + sleep 1; + } + + is($proc1b->get_field('counter'), 10, "Incremented"); + is($proc1b->get_field('exit'), 0, "Exit value set to 0"); + }; + }; + + ok($proc1a->is_running, "Running check"); + + $proc1a->wait; + + is($proc1a->get_field('counter'), 10, "Incremented"); + is($proc1a->get_field('exit'), 0, "Exit value set to 0"); + + waitpid($pid, 0); +}; + +done_testing; diff --git a/t/fake.t b/t/fake.t new file mode 100644 index 000000000..a5d3e2996 --- /dev/null +++ b/t/fake.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl +use Test2::V0; +# HARNESS-SMOKE +# HARNESS-STAGE-theone + +use Carp qw/longmess/; + +use Data::Dumper; +print STDERR "WARN: " . ($^W || 0) . "\n"; +print STDERR "ARGS " . Dumper(\@ARGV); + +ok(1, "An assertion"); + +print "Hi!\n"; +print STDERR "Hi!\n"; + +note "A Note!"; +diag "A Diag!"; + +print "Trace: " . longmess(); + +print "STAGE: $ENV{T2_HARNESS_STAGE}\n"; + +print STDOUT "Enter Text:"; +STDOUT->flush(); +my $got = <STDIN> // '<UNDEF>'; +print "Got: $got\n"; + +print "AAA\n"; +#bail_out "foo"; +print "AAB\n"; + +subtest subtest_a => sub { + ok(1); +}; + +subtest subtest_b => sub { + subtest subtest_ba => sub { + subtest subtest_bb => sub { + ok(0); + }; + }; +}; + +subtest subtest_c => sub { + ok(0); +}; + +subtest undef, sub { + ok(0); +}; + +diag "TMPDIR: $ENV{TMPDIR}\n"; + +done_testing; diff --git a/t/integration/concurrency.t b/t/integration/concurrency.t deleted file mode 100644 index c9d18dc84..000000000 --- a/t/integration/concurrency.t +++ /dev/null @@ -1,118 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-j4'], - log => 1, - exit => 0, - test => sub { - my $out = shift; - my $log = $out->{log}; - - my @order; - my @events = $log->poll(); - while (@events) { - if (my $event = shift @events) { - my $f = $event->{facet_data}; - - if (my $e = $f->{harness_job_exit}) { - push @order => [exit => $e->{stamp}]; - } - - if (my $l = $f->{harness_job_start}) { - push @order => [start => $l->{stamp}]; - } - } - - # Check for additional events, probably should not have any, but we may hit - # a buffering limit in the log reader and need additional polls. - push @events => $log->poll; - } - -# We care about the order in which events happened based on time stamp, not the -# order in which they were collected, which may be different. Here we will sort -# based on stamp. - @order = map { $_->[0] } sort { $a->[1] <=> $b->[1] } @order; - -# The first 4 events should be starts since we have 4 concurrent jobs -# After they start we MUST see an exit before any more can start -# Because of IPC timing we cannot be sure of the order of anything else, but we -# should have 1 more start and 4 more exits in any order. - like(shift @order, qr/start/, "Item $_ is 'start'") for 0 .. 3; - like(shift @order, qr/exit/, "Item 4 must be an exit"); - like( - \@order, - bag { - item qr/start/; - item qr/exit/ for 1 .. 4; - end; - }, - "Got one more start, and 4 more exits" - ); - }, -); - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-j2'], - log => 1, - exit => 0, - test => sub { - my $out = shift; - my $log = $out->{log}; - - my @order; - my @events = $log->poll(); - while (@events) { - if (my $event = shift @events) { - my $f = $event->{facet_data}; - - if (my $e = $f->{harness_job_exit}) { - push @order => [exit => $e->{stamp}]; - } - - if (my $l = $f->{harness_job_start}) { - push @order => [start => $l->{stamp}]; - } - } - - # Check for additional events, probably should not have any, but we may hit - # a buffering limit in the log reader and need additional polls. - push @events => $log->poll; - } - -# We care about the order in which events happened based on time stamp, not the -# order in which they were collected, which may be different. Here we will sort -# based on stamp. - @order = map { $_->[0] } sort { $a->[1] <=> $b->[1] } @order; - -# The first 2 events should be starts since we have 2 concurrent jobs -# After they start we MUST see an exit before any more can start. -# Following that we should either see a start, or, if we want to be generous -# and assume the first 2 tests happened to finish at approx. the same time, -# then another exit followed by 2 starts. - like(shift @order, qr/start/, "Item $_ is 'start'") for 0 .. 1; - like(shift @order, qr/exit/, "Item 2 must be an exit"); - my $next = shift @order; - if ($next =~ /exit/) { - like(shift @order, qr/start/, "Item 4 must be a start if 3 was exit"); - like(shift @order, qr/start/, "Item 5 must be a start if 3 was exit"); - } else { - like($next, qr/start/, "Item 3 must be a start"); - } - }, -); - -done_testing; diff --git a/t/integration/concurrency/a.tx b/t/integration/concurrency/a.tx deleted file mode 100644 index f1b5541ea..000000000 --- a/t/integration/concurrency/a.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -sleep 1; -ok(1, "pass"); -sleep 1; - -done_testing; diff --git a/t/integration/concurrency/b.tx b/t/integration/concurrency/b.tx deleted file mode 100644 index f1b5541ea..000000000 --- a/t/integration/concurrency/b.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -sleep 1; -ok(1, "pass"); -sleep 1; - -done_testing; diff --git a/t/integration/concurrency/c.tx b/t/integration/concurrency/c.tx deleted file mode 100644 index f1b5541ea..000000000 --- a/t/integration/concurrency/c.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -sleep 1; -ok(1, "pass"); -sleep 1; - -done_testing; diff --git a/t/integration/concurrency/d.tx b/t/integration/concurrency/d.tx deleted file mode 100644 index f1b5541ea..000000000 --- a/t/integration/concurrency/d.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -sleep 1; -ok(1, "pass"); -sleep 1; - -done_testing; diff --git a/t/integration/concurrency/e.tx b/t/integration/concurrency/e.tx deleted file mode 100644 index f1b5541ea..000000000 --- a/t/integration/concurrency/e.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -sleep 1; -ok(1, "pass"); -sleep 1; - -done_testing; diff --git a/t/integration/coverage.t b/t/integration/coverage.t deleted file mode 100644 index 4eb7af6e7..000000000 --- a/t/integration/coverage.t +++ /dev/null @@ -1,345 +0,0 @@ -use Test2::V0; -use Test2::Harness::Util::JSON qw/encode_json decode_json/; -use Test2::Require::Module 'Test2::Plugin::Cover' => '0.000022'; - -use App::Yath::Tester qw/yath/; - -use File::Temp qw/tempfile/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my ($fh, $cfile) = tempfile(SUFFIX => '.json'); -close($fh); - -yath( - command => 'test', - args => ["-I$dir/lib", $dir, '--ext=tx', "--cover-write=$cfile", '-v'], - exit => 0, -); - -open($fh, '<', $cfile); -my $json = join '' => <$fh>; -my $coverage = decode_json($json); - -is( - $coverage, - { - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByRun', - 'testmeta' => { - 't/integration/coverage/a.tx' => {'manager' => 'Manager', 'type' => 'split'}, - 't/integration/coverage/b.tx' => {'type' => 'flat'}, - 't/integration/coverage/c.tx' => {'manager' => 'Manager', 'type' => 'split'}, - 't/integration/coverage/once.tx' => {'type' => 'flat'}, - 't/integration/coverage/open.tx' => {'type' => 'flat'}, - 't/integration/coverage/x.tx' => {'type' => 'flat'}, - }, - 'files' => { - 'Ax.pm' => { - '*' => { - 't/integration/coverage/a.tx' => ['*'], - 't/integration/coverage/c.tx' => [{'subtest' => 'a'}], - }, - 'a' => { - 't/integration/coverage/a.tx' => bag { - item {'subtest' => 'c'}; - item {'subtest' => 'b'}; - item {'subtest' => 'a'}; - end; - }, - 't/integration/coverage/c.tx' => bag { - item {'subtest' => 'c'}; - item {'subtest' => 'a'}; - end; - }, - }, - 'aa' => {'t/integration/coverage/a.tx' => [{'subtest' => 'a'}]}, - }, - 'Bx.pm' => { - '*' => { - 't/integration/coverage/a.tx' => ['*'], - 't/integration/coverage/b.tx' => ['*'], - 't/integration/coverage/x.tx' => ['*'], - }, - '<>' => {'t/integration/coverage/open.tx' => ['*']}, - 'b' => { - 't/integration/coverage/a.tx' => bag { - item {'subtest' => 'c'}; - item {'subtest' => 'b'}; - end; - }, - 't/integration/coverage/b.tx' => ['*'], - }, - }, - 'Cx.pm' => { - '*' => { - 't/integration/coverage/a.tx' => ['*'], - 't/integration/coverage/c.tx' => [{'subtest' => 'c'}], - }, - 'c' => { - 't/integration/coverage/a.tx' => [ - '*', - {'subtest' => 'c'}, - ], - 't/integration/coverage/c.tx' => [{'subtest' => 'c'}] - }, - }, - }, - }, - "Got predicted coverage data", -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - 't/integration/coverage/a.tx' => {env => {COVER_TEST_SUBTESTS => 'a, b, c'}, stdin => "a\nb\nc\n", argv => ['a', 'b', 'c']}, - 't/integration/coverage/c.tx' => {env => {COVER_TEST_SUBTESTS => 'a, c'}, stdin => "a\nc\n", argv => ['a', 'c']}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - # No manager, so run entire tests - 't/integration/coverage/b.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/x.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/open.tx' => {argv => [], env => {}, stdin => ''}, - - # Managed, so we have custom input - 't/integration/coverage/a.tx' => {'argv' => ['b', 'c'], 'env' => {'COVER_TEST_SUBTESTS' => 'b, c'}, 'stdin' => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bxb'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/b.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/open.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/x.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - - "t/integration/coverage/a.tx" => {"argv" => ["b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "b, c"}, "stdin" => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cxc'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax*'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'AxCx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -# Add some tests that do not exist, coverage testing shoudl warn and should skip them. -$coverage->{testmeta}->{'t/integration/coverage/mia1.tx'} = $coverage->{testmeta}->{'t/integration/coverage/a.tx'}; -$coverage->{testmeta}->{'t/integration/coverage/mia2.tx'} = $coverage->{testmeta}->{'t/integration/coverage/b.tx'}; - -$coverage->{files}->{'Ax.pm'}->{'*'}->{'t/integration/coverage/mia1.tx'} = ['*']; -$coverage->{files}->{'Ax.pm'}->{'*'}->{'t/integration/coverage/mia2.tx'} = ['*']; - -open($fh, '>', $cfile) or die "Could not open file: $!"; -my $njson = encode_json($coverage); -print $fh $njson; -close($fh); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - 't/integration/coverage/a.tx' => {env => {COVER_TEST_SUBTESTS => 'a, b, c'}, stdin => "a\nb\nc\n", argv => ['a', 'b', 'c']}, - 't/integration/coverage/c.tx' => {env => {COVER_TEST_SUBTESTS => 'a, c'}, stdin => "a\nc\n", argv => ['a', 'c']}, - }, - "Test got the correct input about what subtests to run", - ); - - like( - $out->{output}, - qr{Coverage wants to run test 't/integration/coverage/mia1\.tx', but it does not exist, skipping\.\.\.}, - "Skipped mia1 because it does not exist", - ); - - like( - $out->{output}, - qr{Coverage wants to run test 't/integration/coverage/mia2\.tx', but it does not exist, skipping\.\.\.}, - "Skipped mia2 because it does not exist", - ); - }, -); - -done_testing; diff --git a/t/integration/coverage/a.tx b/t/integration/coverage/a.tx deleted file mode 100644 index 5d57bec7f..000000000 --- a/t/integration/coverage/a.tx +++ /dev/null @@ -1,46 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -STDIN->blocking(0); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - -use Ax; -use Bx; -use Cx; - -Test2::Plugin::Cover->set_from_manager('Manager'); -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); - -is(Cx->c, 'c', "Got c"); - -subtest a => sub { - Test2::Plugin::Cover->set_from({subtest => 'a'}); - is(Ax->a, 'a', "Got a"); - is(Ax->aa, 'aa', "Got aa"); - Test2::Plugin::Cover->clear_from(); -}; - -subtest b => sub { - Test2::Plugin::Cover->set_from({subtest => 'b'}); - is(Ax->a, 'a', "Got a"); - is(Bx->b, 'b', "Got b"); - Test2::Plugin::Cover->clear_from(); -}; - -subtest c => sub { - Test2::Plugin::Cover->set_from({subtest => 'c'}); - is(Ax->a, 'a', "Got a"); - is(Bx->b, 'b', "Got b"); - is(Cx->c, 'c', "Got c"); - Test2::Plugin::Cover->clear_from(); -}; - -done_testing; diff --git a/t/integration/coverage/b.tx b/t/integration/coverage/b.tx deleted file mode 100644 index 5bda36400..000000000 --- a/t/integration/coverage/b.tx +++ /dev/null @@ -1,21 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -STDIN->blocking(0); - -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - -use Bx; - -is(Bx->b, 'b', "Got b"); - -done_testing; diff --git a/t/integration/coverage/c.tx b/t/integration/coverage/c.tx deleted file mode 100644 index 38bb3cd5a..000000000 --- a/t/integration/coverage/c.tx +++ /dev/null @@ -1,34 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -Test2::Plugin::Cover->set_from_manager('Manager'); -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); - -STDIN->blocking(0); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - -subtest a => sub { - Test2::Plugin::Cover->set_from({subtest => 'a'}); - require Ax; - is(Ax->a, 'a', "Got a"); - Test2::Plugin::Cover->clear_from(); -}; - -subtest c => sub { - Test2::Plugin::Cover->set_from({subtest => 'c'}); - require Ax; - require Cx; - is(Ax->a, 'a', "Got a"); - is(Cx->c, 'c', "Got c"); - Test2::Plugin::Cover->clear_from(); -}; - -done_testing; diff --git a/t/integration/coverage/lib/Ax.pm b/t/integration/coverage/lib/Ax.pm deleted file mode 100644 index 75e2e8169..000000000 --- a/t/integration/coverage/lib/Ax.pm +++ /dev/null @@ -1,11 +0,0 @@ -package Ax; -use strict; -use warnings; - -# This is here for simulating a non-sub change -my $A = 'a'; - -sub a { 'a' } -sub aa { 'aa' } - -1; diff --git a/t/integration/coverage/lib/Bx.pm b/t/integration/coverage/lib/Bx.pm deleted file mode 100644 index d9e00233a..000000000 --- a/t/integration/coverage/lib/Bx.pm +++ /dev/null @@ -1,7 +0,0 @@ -package Bx; -use strict; -use warnings; - -sub b { 'b' } - -1; diff --git a/t/integration/coverage/lib/Cx.pm b/t/integration/coverage/lib/Cx.pm deleted file mode 100644 index 1ae65194e..000000000 --- a/t/integration/coverage/lib/Cx.pm +++ /dev/null @@ -1,7 +0,0 @@ -package Cx; -use strict; -use warnings; - -sub c { 'c' } - -1; diff --git a/t/integration/coverage/lib/Manager.pm b/t/integration/coverage/lib/Manager.pm deleted file mode 100644 index da96d0239..000000000 --- a/t/integration/coverage/lib/Manager.pm +++ /dev/null @@ -1,33 +0,0 @@ -package Manager; -use strict; -use warnings; - -sub test_parameters { - my $class = shift; - my ($test, $coverage_data) = @_; - - my %seen; - my @subtests; - - for my $set (values %$coverage_data) { - for my $value (@$set) { - next unless ref $value eq 'HASH'; - my $subtest = $value->{subtest} or next; - next if $seen{$subtest}++; - push @subtests => $subtest; - } - } - - return unless @subtests; - - @subtests = sort @subtests; - - return { - run => 1, - env => { COVER_TEST_SUBTESTS => join(", " => @subtests) }, - argv => \@subtests, - stdin => join("\n" => @subtests) . "\n", - }; -} - -1; diff --git a/t/integration/coverage/lib/Plugin.pm b/t/integration/coverage/lib/Plugin.pm deleted file mode 100644 index 6621679f4..000000000 --- a/t/integration/coverage/lib/Plugin.pm +++ /dev/null @@ -1,22 +0,0 @@ -package Plugin; -use strict; -use warnings; - -use parent 'App::Yath::Plugin'; - -sub changed_files { - return () unless $ENV{TEST_CASE}; - return (['Ax.pm']) if $ENV{TEST_CASE} eq 'Ax'; - return (['Bx.pm']) if $ENV{TEST_CASE} eq 'Bx'; - return (['Cx.pm']) if $ENV{TEST_CASE} eq 'Cx'; - return (['Bx.pm', 'b']) if $ENV{TEST_CASE} eq 'Bxb'; - return (['Cx.pm', 'c']) if $ENV{TEST_CASE} eq 'Cxc'; - return (['Ax.pm', '*']) if $ENV{TEST_CASE} eq 'Ax*'; - return (['Ax.pm', 'a']) if $ENV{TEST_CASE} eq 'Axa'; - return (['Ax.pm', 'aa']) if $ENV{TEST_CASE} eq 'Axaa'; - return (['Ax.pm', 'aa', 'a']) if $ENV{TEST_CASE} eq 'Axaaa'; - return (['Ax.pm', 'a'], ['Cx.pm', 'c']) if $ENV{TEST_CASE} eq 'AxCx'; - return (); -} - -1; diff --git a/t/integration/coverage/once.tx b/t/integration/coverage/once.tx deleted file mode 100644 index 2b8489f80..000000000 --- a/t/integration/coverage/once.tx +++ /dev/null @@ -1,18 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -STDIN->blocking(0); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - -ok(1); - -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); -done_testing; diff --git a/t/integration/coverage/open.tx b/t/integration/coverage/open.tx deleted file mode 100644 index e4c23b3f8..000000000 --- a/t/integration/coverage/open.tx +++ /dev/null @@ -1,22 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -STDIN->blocking(0); - -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - - -open(my $fh, '<', "t/integration/coverage/lib/Bx.pm"); - -ok(1); - -done_testing; diff --git a/t/integration/coverage/x.tx b/t/integration/coverage/x.tx deleted file mode 100644 index a53b19c7b..000000000 --- a/t/integration/coverage/x.tx +++ /dev/null @@ -1,21 +0,0 @@ -use Test2::V0; -use Test2::Plugin::Cover; -use Path::Tiny; - -use Test2::Harness::Util::JSON qw/encode_json/; - -STDIN->blocking(0); - -Test2::Plugin::Cover->set_root(path('t/integration/coverage/lib')->realpath); - -print "INPUT ${ \__FILE__ }: " . encode_json({ - env => {map { ($_ => $ENV{$_}) } grep { m/^COVER_TEST_/ } keys %ENV}, - argv => [@ARGV], - stdin => join('' => <STDIN>), -}) . "\n"; - -require Bx; - -ok(1); - -done_testing; diff --git a/t/integration/coverage2.t b/t/integration/coverage2.t deleted file mode 100644 index ef7063f07..000000000 --- a/t/integration/coverage2.t +++ /dev/null @@ -1,310 +0,0 @@ -use Test2::V0; -use Test2::Harness::Util::JSON qw/encode_json decode_json/; -use Test2::Require::Module 'Test2::Plugin::Cover' => '0.000022'; - -use App::Yath::Tester qw/yath/; - -use File::Temp qw/tempfile/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; -$dir =~ s/\d+$//; - -my ($fh, $cfile) = tempfile(SUFFIX => '.jsonl'); -close($fh); - -yath( - command => 'test', - args => ["-I$dir/lib", $dir, '--ext=tx', "--cover-write=$cfile", '-v'], - exit => 0, -); - -my @coverage; -open($fh, '<', $cfile); -for my $line (<$fh>) { - next unless $line; - push @coverage => decode_json($line); -} - -is( - \@coverage, - bag { - item { - 'test' => 't/integration/coverage/a.tx', - 'manager' => 'Manager', - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'files' => { - 'Ax.pm' => { - '*' => ['*'], - 'a' => bag { item {'subtest' => 'b'}; item {'subtest' => 'c'}; item {'subtest' => 'a'} }, - 'aa' => [{'subtest' => 'a'}], - }, - 'Bx.pm' => { - 'b' => bag { item {'subtest' => 'b'}; item {'subtest' => 'c'} }, - '*' => ['*'], - }, - 'Cx.pm' => { - 'c' => bag { item '*'; item {'subtest' => 'c'} }, - '*' => ['*'], - }, - }, - }; - - item { - 'test' => 't/integration/coverage/b.tx', - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'files' => { - 'Bx.pm' => { - 'b' => ['*'], - '*' => ['*'], - }, - }, - }; - - item { - 'test' => 't/integration/coverage/c.tx', - 'manager' => 'Manager', - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'files' => { - 'Ax.pm' => { - 'a' => bag { item {'subtest' => 'c'}; item {'subtest' => 'a'} }, - '*' => [{'subtest' => 'a'}], - }, - 'Cx.pm' => { - 'c' => [{'subtest' => 'c'}], - '*' => [{'subtest' => 'c'}], - } - } - }; - - item { - 'test' => 't/integration/coverage/once.tx', - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'files' => {}, - }; - - item { - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'test' => 't/integration/coverage/open.tx', - 'files' => {'Bx.pm' => {'<>' => ['*']}}, - }; - - item { - 'test' => 't/integration/coverage/x.tx', - 'aggregator' => 'Test2::Harness::Log::CoverageAggregator::ByTest', - 'files' => {'Bx.pm' => {'*' => ['*']}}, - }; - }, - "Got predicted coverage data", -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - 't/integration/coverage/a.tx' => {env => {COVER_TEST_SUBTESTS => 'a, b, c'}, stdin => "a\nb\nc\n", argv => ['a', 'b', 'c']}, - 't/integration/coverage/c.tx' => {env => {COVER_TEST_SUBTESTS => 'a, c'}, stdin => "a\nc\n", argv => ['a', 'c']}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - # No manager, so run entire tests - 't/integration/coverage/b.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/x.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/open.tx' => {argv => [], env => {}, stdin => ''}, - - # Managed, so we have custom input - 't/integration/coverage/a.tx' => {'argv' => ['b', 'c'], 'env' => {'COVER_TEST_SUBTESTS' => 'b, c'}, 'stdin' => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bxb'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/b.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/open.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/x.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - - "t/integration/coverage/a.tx" => {"argv" => ["b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "b, c"}, "stdin" => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cxc'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax*'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$cfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'AxCx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -done_testing; diff --git a/t/integration/coverage3.t b/t/integration/coverage3.t deleted file mode 100644 index 7b16929ac..000000000 --- a/t/integration/coverage3.t +++ /dev/null @@ -1,231 +0,0 @@ -use Test2::V0; -use Test2::Harness::Util::JSON qw/encode_json decode_json/; -use Test2::Require::Module 'Test2::Plugin::Cover' => '0.000022'; - -use App::Yath::Tester qw/yath/; - -use File::Temp qw/tempfile/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; -$dir =~ s/\d+$//; - -my ($fh, $logfile) = tempfile("yathlog-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.jsonl.bz2'); -close($fh); - -yath( - command => 'test', - args => ["-I$dir/lib", $dir, '--ext=tx', '-v', '-B', '-F' => $logfile, '--cover-files', '--cover-agg' => 'ByRun'], - exit => 0, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - 't/integration/coverage/a.tx' => {env => {COVER_TEST_SUBTESTS => 'a, b, c'}, stdin => "a\nb\nc\n", argv => ['a', 'b', 'c']}, - 't/integration/coverage/c.tx' => {env => {COVER_TEST_SUBTESTS => 'a, c'}, stdin => "a\nc\n", argv => ['a', 'c']}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - # No manager, so run entire tests - 't/integration/coverage/b.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/x.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/open.tx' => {argv => [], env => {}, stdin => ''}, - - # Managed, so we have custom input - 't/integration/coverage/a.tx' => {'argv' => ['b', 'c'], 'env' => {'COVER_TEST_SUBTESTS' => 'b, c'}, 'stdin' => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bxb'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/b.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/open.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/x.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - - "t/integration/coverage/a.tx" => {"argv" => ["b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "b, c"}, "stdin" => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cxc'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax*'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'AxCx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -done_testing; diff --git a/t/integration/coverage4.t b/t/integration/coverage4.t deleted file mode 100644 index bc0eafe81..000000000 --- a/t/integration/coverage4.t +++ /dev/null @@ -1,231 +0,0 @@ -use Test2::V0; -use Test2::Harness::Util::JSON qw/encode_json decode_json/; -use Test2::Require::Module 'Test2::Plugin::Cover' => '0.000022'; - -use App::Yath::Tester qw/yath/; - -use File::Temp qw/tempfile/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; -$dir =~ s/\d+$//; - -my ($fh, $logfile) = tempfile("yathlog-$$-XXXXXXXX", TMPDIR => 1, UNLINK => 1, SUFFIX => '.jsonl.bz2'); -close($fh); - -yath( - command => 'test', - args => ["-I$dir/lib", $dir, '--ext=tx', '-v', '-B', '-F' => $logfile, '--cover-files', '--cover-agg' => 'ByTest'], - exit => 0, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - 't/integration/coverage/a.tx' => {env => {COVER_TEST_SUBTESTS => 'a, b, c'}, stdin => "a\nb\nc\n", argv => ['a', 'b', 'c']}, - 't/integration/coverage/c.tx' => {env => {COVER_TEST_SUBTESTS => 'a, c'}, stdin => "a\nc\n", argv => ['a', 'c']}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - # No manager, so run entire tests - 't/integration/coverage/b.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/x.tx' => {argv => [], env => {}, stdin => ''}, - 't/integration/coverage/open.tx' => {argv => [], env => {}, stdin => ''}, - - # Managed, so we have custom input - 't/integration/coverage/a.tx' => {'argv' => ['b', 'c'], 'env' => {'COVER_TEST_SUBTESTS' => 'b, c'}, 'stdin' => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Bxb'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/b.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/open.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - "t/integration/coverage/x.tx" => {"argv" => [], "env" => {}, "stdin" => ""}, - - "t/integration/coverage/a.tx" => {"argv" => ["b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "b, c"}, "stdin" => "b\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Cxc'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["c"], "env" => {"COVER_TEST_SUBTESTS" => "c"}, "stdin" => "c\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Ax*'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a"], "env" => {"COVER_TEST_SUBTESTS" => "a"}, "stdin" => "a\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'Axaaa'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -yath( - command => 'test', - args => ["-D$dir/lib", "-I$dir/lib", '--ext=tx', "--cover-from=$logfile", '--plugin' => '+Plugin', '--changed-only', '-v'], - exit => 0, - env => {TEST_CASE => 'AxCx'}, - test => sub { - my $out = shift; - my $input = +{$out->{output} =~ m/INPUT (\S+): (\{.+\})$/gm}; - $_ = decode_json($_) for values %$input; - is( - $input, - { - "t/integration/coverage/a.tx" => {"argv" => ["a", "b", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, b, c"}, "stdin" => "a\nb\nc\n"}, - "t/integration/coverage/c.tx" => {"argv" => ["a", "c"], "env" => {"COVER_TEST_SUBTESTS" => "a, c"}, "stdin" => "a\nc\n"}, - }, - "Test got the correct input about what subtests to run", - ); - }, -); - -done_testing; diff --git a/t/integration/encoding.t b/t/integration/encoding.t deleted file mode 100644 index 33c098122..000000000 --- a/t/integration/encoding.t +++ /dev/null @@ -1,58 +0,0 @@ -use Test2::V0; - -use App::Yath::Tester qw/yath/; -use File::Temp qw/tempdir/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my $want = <<"EOT"; -( NOTE ) job 1 valid note [\x{201c}\x{201d}\x{ff}\x{ff}] -( NOTE ) job 1 valid note [\x{201c}\x{201d}] -( DIAG ) job 1 valid diag [\x{201c}\x{201d}\x{ff}\x{ff}] -( DIAG ) job 1 valid diag [\x{201c}\x{201d}] -( STDOUT ) job 1 valid stdout [\x{201c}\x{201d}\x{ff}\x{ff}] -( STDOUT ) job 1 valid stdout [\x{201c}\x{201d}] -( STDERR ) job 1 valid stderr [\x{201c}\x{201d}\x{ff}\x{ff}] -( STDERR ) job 1 valid stderr [\x{201c}\x{201d}] -[ PASS ] job 1 + valid ok [\x{201c}\x{201d}\x{ff}\x{ff}] -[ PASS ] job 1 + valid ok [\x{201c}\x{201d}] -( STDOUT ) job 1 STDOUT: M\x{101}kaha -( STDERR ) job 1 STDERR: M\x{101}kaha -( DIAG ) job 1 DIAG: M\x{101}kaha -( NOTE ) job 1 NOTE: M\x{101}kaha -[ PASS ] job 1 + ASSERT: M\x{101}kaha -[ PASS ] job 1 + \x{406} \x{449}\x{435} \x{442}\x{440}\x{43e}\x{445}\x{438} -EOT - -yath( - command => 'test', - args => ['-v', "$dir/plugin.tx"], - exit => 0, - encoding => 'utf8', - test => sub { - my $out = shift; - like($out->{output}, qr/\Q$want\E/, "Got proper codepoints"); - }, -); - -yath( - command => 'test', - args => ['-v', "$dir/no-plugin.tx"], - exit => 0, - test => sub { - my $out = shift; - - utf8::encode( my $raw_want = $want ); - utf8::encode( my $u00ff = "\x{ff}" ); - $raw_want =~ s<\Q$u00ff\E><\xff>g; - - like($out->{output}, qr/\Q$raw_want\E/, "Got proper codepoints"); - }, -); - -done_testing; diff --git a/t/integration/encoding/no-plugin.tx b/t/integration/encoding/no-plugin.tx deleted file mode 100644 index bdee7b7b4..000000000 --- a/t/integration/encoding/no-plugin.tx +++ /dev/null @@ -1,29 +0,0 @@ -use strict; -use warnings; - -use Test::More; - -note "valid note [“”\xff\xff]"; -note "valid note [“”]"; - -diag "valid diag [“”\xff\xff]"; -diag "valid diag [“”]"; - -print "valid stdout [“”\xff\xff]\n"; -print "valid stdout [“”]\n"; - -print STDERR "valid stderr [“”\xff\xff]\n"; -print STDERR "valid stderr [“”]\n"; - -ok 1, "valid ok [“”\xff\xff]"; -ok 1, "valid ok [“”]"; - -print STDOUT "STDOUT: Mākaha\n"; -print STDERR "STDERR: Mākaha\n"; -diag "DIAG: Mākaha"; -note "NOTE: Mākaha"; -ok(1, "ASSERT: Mākaha"); -ok(1, "І ще трохи"); - -done_testing(); - diff --git a/t/integration/encoding/plugin.tx b/t/integration/encoding/plugin.tx deleted file mode 100644 index 9458e2cde..000000000 --- a/t/integration/encoding/plugin.tx +++ /dev/null @@ -1,29 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test2::Plugin::UTF8; - -note "valid note [“”\xff\xff]"; -note "valid note [“”]"; - -diag "valid diag [“”\xff\xff]"; -diag "valid diag [“”]"; - -print "valid stdout [“”\xff\xff]\n"; -print "valid stdout [“”]\n"; - -print STDERR "valid stderr [“”\xff\xff]\n"; -print STDERR "valid stderr [“”]\n"; - -ok 1, "valid ok [“”\xff\xff]"; -ok 1, "valid ok [“”]"; - -print STDOUT "STDOUT: Mākaha\n"; -print STDERR "STDERR: Mākaha\n"; -diag "DIAG: Mākaha"; -note "NOTE: Mākaha"; -ok(1, "ASSERT: Mākaha"); -ok(1, "І ще трохи"); - -done_testing(); diff --git a/t/integration/failed.t b/t/integration/failed.t deleted file mode 100644 index c0c890325..000000000 --- a/t/integration/failed.t +++ /dev/null @@ -1,42 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx'], - log => 1, - exit => T(), - test => sub { - my $out = shift; - my $logfile = $out->{log}->name; - - $out = yath( - command => 'failed', - args => [$logfile], - env => {TABLE_TERM_SIZE => 1000, TS_TERM_SIZE => 1000}, - exit => 0, - test => sub { - my $out = shift; - - ok(!$out->{exit}, "'failed' command exits true"); - like($out->{output}, qr{fail\.tx}, "'fail.tx' was seen as a failure when reading the log"); - unlike($out->{output}, qr{pass\.tx}, "'pass.tx' was not seen as a failure when reading the log"); - }, - ); - }, -); - - - -done_testing; diff --git a/t/integration/failed/fail.tx b/t/integration/failed/fail.tx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/failed/fail.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/failed/pass.tx b/t/integration/failed/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/failed/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/failure_cases.t b/t/integration/failure_cases.t deleted file mode 100644 index 0b07b8e54..000000000 --- a/t/integration/failure_cases.t +++ /dev/null @@ -1,52 +0,0 @@ -use Test2::V0; -# HARNESS-DURATION-LONG - -use Test2::API qw/context/; -use App::Yath::Tester qw/yath/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my %CUSTOM = ( - "timeout.tx" => ['--et', 2], - "post_exit_timeout.tx" => ['--pet', 2], - "noplan.tx" => ['--pet', 2], - "dupnums.tx" => [], - "missingnums.tx" => [], -); - -opendir(my $DH, $dir) or die "Could not open directory $dir: $!"; - -for my $file (readdir($DH)) { - run_test($file); -} - -sub run_test { - my ($file) = @_; - my $path = File::Spec->canonpath("$dir/$file"); - return unless -f $path; - my $args = $CUSTOM{$file}; - - my $ctx = context(); - - my @final_args = (@{$args || []}, $path); - - yath( - command => 'test', - args => \@final_args, - env => {FAILURE_DO_PASS => 0}, - exit => T(), - ); - - yath( - command => 'test', - args => \@final_args, - env => {FAILURE_DO_PASS => 1}, - exit => F(), - ); - - $ctx->release; -} - -done_testing; diff --git a/t/integration/failure_cases/badplan.tx b/t/integration/failure_cases/badplan.tx deleted file mode 100644 index 21c594e8e..000000000 --- a/t/integration/failure_cases/badplan.tx +++ /dev/null @@ -1,7 +0,0 @@ -print <<EOT; -1..2 -ok foo -ok bar -EOT - -print "ok baz\n" unless $ENV{FAILURE_DO_PASS}; diff --git a/t/integration/failure_cases/buffered_subtest_abrupt_end.tx b/t/integration/failure_cases/buffered_subtest_abrupt_end.tx deleted file mode 100644 index ca1421da8..000000000 --- a/t/integration/failure_cases/buffered_subtest_abrupt_end.tx +++ /dev/null @@ -1,14 +0,0 @@ -use strict; -use warnings; - -my $end = $ENV{FAILURE_DO_PASS} ? "}\n" : ""; - -print <<EOT; -ok - foo { - ok - pass - 1..1 -${end}ok - bar -1..2 -EOT - -exit 0; diff --git a/t/integration/failure_cases/buffered_subtest_abrupt_end_nested.tx b/t/integration/failure_cases/buffered_subtest_abrupt_end_nested.tx deleted file mode 100644 index 1a513d6b5..000000000 --- a/t/integration/failure_cases/buffered_subtest_abrupt_end_nested.tx +++ /dev/null @@ -1,17 +0,0 @@ -use strict; -use warnings; - -my $end = $ENV{FAILURE_DO_PASS} ? "}\n " : ""; - -print <<EOT; -ok - outer { - ok - foo { - ok - pass - 1..1 - ${end}ok - bar - 1..2 -} -1..1 -EOT - -exit 0; diff --git a/t/integration/failure_cases/dupnums.tx b/t/integration/failure_cases/dupnums.tx deleted file mode 100644 index a4bef3bd7..000000000 --- a/t/integration/failure_cases/dupnums.tx +++ /dev/null @@ -1,10 +0,0 @@ -my $out = <<EOT; -ok 1 - foo -ok 2 - bar -ok 3 - baz -EOT - -print $out; -print $out unless $ENV{FAILURE_DO_PASS}; - -print "1.." . ($ENV{FAILURE_DO_PASS} ? 3 : 6) . "\n"; diff --git a/t/integration/failure_cases/exit.tx b/t/integration/failure_cases/exit.tx deleted file mode 100644 index 18362e5f7..000000000 --- a/t/integration/failure_cases/exit.tx +++ /dev/null @@ -1,8 +0,0 @@ -use Test2::Tools::Tiny; -use strict; -use warnings; - -ok(1); -done_testing; - -exit(123) unless $ENV{FAILURE_DO_PASS}; diff --git a/t/integration/failure_cases/missingnums.tx b/t/integration/failure_cases/missingnums.tx deleted file mode 100644 index a5028c814..000000000 --- a/t/integration/failure_cases/missingnums.tx +++ /dev/null @@ -1,7 +0,0 @@ -my $i = 1; - -print "ok " . $i++ . "\n"; -$i++ unless $ENV{FAILURE_DO_PASS}; -print "ok " . $i++ . "\n"; - -print "1..2\n"; diff --git a/t/integration/failure_cases/nested_subtest.tx b/t/integration/failure_cases/nested_subtest.tx deleted file mode 100644 index 104b26762..000000000 --- a/t/integration/failure_cases/nested_subtest.tx +++ /dev/null @@ -1,11 +0,0 @@ -use Test2::V0; - -subtest foo => sub { - subtest bar => sub { - subtest baz => sub { - ok($ENV{FAILURE_DO_PASS}, "check env"); - }; - }; -}; - -done_testing; diff --git a/t/integration/failure_cases/nested_subtest_exception.tx b/t/integration/failure_cases/nested_subtest_exception.tx deleted file mode 100644 index 124303440..000000000 --- a/t/integration/failure_cases/nested_subtest_exception.tx +++ /dev/null @@ -1,40 +0,0 @@ -use Test2::V0; -use Test2::API qw/context/; - -{ - $INC{'My/Event.pm'} = 1; - package My::Event; - use parent 'Test2::Event'; - - use Test2::Util::Facets2Legacy ':ALL'; - - sub facet_data { - my $self = shift; - - my $out = $self->common_facet_data; - - $out->{errors} = [ - { tag => 'OOPS', fail => !$ENV{FAILURE_DO_PASS}, details => "An error occured" } - ]; - - return $out; - } -} - -subtest foo => sub { - subtest bar => sub { - subtest baz => sub { - ok(1, "pass"); - - sub { - my $ctx = context; - - $ctx->send_event('+My::Event'); - - $ctx->release; - }->(); - }; - }; -}; - -done_testing; diff --git a/t/integration/failure_cases/noplan.tx b/t/integration/failure_cases/noplan.tx deleted file mode 100644 index 34233fa48..000000000 --- a/t/integration/failure_cases/noplan.tx +++ /dev/null @@ -1,6 +0,0 @@ -print <<EOT; -ok foo -ok bar -EOT - -print "1..2\n" if $ENV{FAILURE_DO_PASS}; diff --git a/t/integration/failure_cases/notok.tx b/t/integration/failure_cases/notok.tx deleted file mode 100644 index da053c80d..000000000 --- a/t/integration/failure_cases/notok.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::Tools::Tiny; - -ok($ENV{FAILURE_DO_PASS}, "check env"); - -done_testing; diff --git a/t/integration/failure_cases/parse_error.tx b/t/integration/failure_cases/parse_error.tx deleted file mode 100644 index dcfc76ea3..000000000 --- a/t/integration/failure_cases/parse_error.tx +++ /dev/null @@ -1,9 +0,0 @@ -use Test2::V0; - -use goto::file( - $ENV{FAILURE_DO_PASS} - ? ['ok(1); done_testing;'] - : ['ok(; done_testing;'] -); - -die "Should not see this!"; diff --git a/t/integration/failure_cases/post_exit_timeout.tx b/t/integration/failure_cases/post_exit_timeout.tx deleted file mode 100644 index c4c720eab..000000000 --- a/t/integration/failure_cases/post_exit_timeout.tx +++ /dev/null @@ -1,8 +0,0 @@ -print <<EOT; -1..2 -ok foo -EOT - -exit(0) unless $ENV{FAILURE_DO_PASS}; - -print "ok bar\n"; diff --git a/t/integration/failure_cases/subtest.tx b/t/integration/failure_cases/subtest.tx deleted file mode 100644 index 43033c5d2..000000000 --- a/t/integration/failure_cases/subtest.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -subtest foo => sub { - ok($ENV{FAILURE_DO_PASS}, "check env"); -}; - -done_testing; diff --git a/t/integration/failure_cases/timeout.tx b/t/integration/failure_cases/timeout.tx deleted file mode 100644 index d27e3605d..000000000 --- a/t/integration/failure_cases/timeout.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::Tools::Tiny; - -sleep 60 unless $ENV{FAILURE_DO_PASS}; - -ok(1); -done_testing; diff --git a/t/integration/help.t b/t/integration/help.t deleted file mode 100644 index b6a5b84bb..000000000 --- a/t/integration/help.t +++ /dev/null @@ -1,68 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use App::Yath::Util qw/find_yath/; - -yath( - command => 'help', - args => [], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{^Usage: .*yath COMMAND \[options\]$}m, "Found usage statement"); - like($out->{output}, qr{^Available Commands:$}m, "available commands"); - - # Sample some essential commands - like($out->{output}, qr{^\s+help: Show the list of commands$}m, "'help' command is listed"); - like($out->{output}, qr{^\s+test: Run tests$}m, "'test' command is listed"); - like($out->{output}, qr{^\s+start: Start the persistent test runner$}m, "'start' command is listed"); - }, -); - -yath( - command => 'help', - args => ['help'], - exit => 0, - test => sub { - my $out = shift; - my $script = find_yath(); - - is($out->{output}, <<" EOT", "Got output for the help command"); -help - Show the list of commands - -This command provides a list of commands when called with no arguments. -When given a command name as an argument it will print the help for that -command. - -Usage: $script help - EOT - }, -); - -yath( - command => 'help', - args => ['test'], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{^test - Run tests$}m, "Found summary"); - like($out->{output}, qr{^\[YATH OPTIONS\]$}m, "Found yath options"); - like($out->{output}, qr{^ Developer$}m, "Found Developer category"); - like($out->{output}, qr{^ Help and Debugging$}m, "Found help category"); - like($out->{output}, qr{^ Plugins$}m, "Found plugin category"); - like($out->{output}, qr{^\[COMMAND OPTIONS\]$}m, "Found command options"); - like($out->{output}, qr{^ Display Options$}m, "Found display category"); - like($out->{output}, qr{^ Formatter Options$}m, "Found formatter category"); - like($out->{output}, qr{^ Logging Options$}m, "Found logging category"); - like($out->{output}, qr{^ Run Options$}m, "Found run category"); - like($out->{output}, qr{^ Runner Options$}m, "Found runner category"); - like($out->{output}, qr{^ Workspace Options$}m, "Found workspace category"); - }, -); - -done_testing; diff --git a/t/integration/includes.t b/t/integration/includes.t deleted file mode 100644 index a0f355ff0..000000000 --- a/t/integration/includes.t +++ /dev/null @@ -1,55 +0,0 @@ -use Test2::V0; -use IPC::Cmd qw/can_run/; - -use File::Spec; - -use App::Yath::Tester qw/yath/; - -use App::Yath::Util qw/find_yath/; -find_yath(); # cache result before we chdir - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -chdir($dir); -$ENV{OLD_PERL5LIB} = $ENV{PERL5LIB}; - -yath( - command => 'test', - args => ['default.tx'], - exit => 0, -); - -yath( - command => 'test', - args => ['-Ixyz', 'default-i.tx'], - exit => 0, -); - -yath( - command => 'test', - args => ['-Ia', '-b', '-Ib', '-l', '-Ic', 'order-ibili.tx'], - exit => 0, -); - -yath( - command => 'test', - args => ['-Ia', '-l', '-Ib', '-b', '-Ic', 'order-ilibi.tx'], - exit => 0, -); - -yath( - command => 'test', - args => ['-Ixyz', '--unsafe-inc', 'dot-last.tx'], - exit => 0, -); - -$ENV{YATH_PERL} = $^X; -yath( - command => 'test', - args => ['-Ixyz', './not-perl.sh'], - exit => 0, -) if can_run('bash'); - -done_testing; diff --git a/t/integration/includes/.yath.rc b/t/integration/includes/.yath.rc deleted file mode 100644 index b64aea458..000000000 --- a/t/integration/includes/.yath.rc +++ /dev/null @@ -1 +0,0 @@ -[test] diff --git a/t/integration/includes/default-i.tx b/t/integration/includes/default-i.tx deleted file mode 100644 index f5c90d447..000000000 --- a/t/integration/includes/default-i.tx +++ /dev/null @@ -1,25 +0,0 @@ -use Test2::V0; - -use File::Spec; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -require App::Yath; - -like( - \@INC, - [ - App::Yath->app_path, - File::Spec->catdir($path, 'xyz'), - File::Spec->catdir($path, 'lib'), - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - ], - "Added lib, blib/lib, and blib/arch AFTER the -Ixyz" -); - -is($ENV{PERL5LIB}, $ENV{OLD_PERL5LIB}, "PERL5LIB has not been modified"); - -done_testing; diff --git a/t/integration/includes/default.tx b/t/integration/includes/default.tx deleted file mode 100644 index 163114a8a..000000000 --- a/t/integration/includes/default.tx +++ /dev/null @@ -1,24 +0,0 @@ -use Test2::V0; - -require App::Yath; - -use File::Spec; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -like( - \@INC, - [ - App::Yath->app_path, - File::Spec->catdir($path, 'lib'), - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - ], - "Added lib, blib/lib, and blib/arch to the front of the line" -); - -is($ENV{PERL5LIB}, $ENV{OLD_PERL5LIB}, "PERL5LIB has not been modified"); - -done_testing; diff --git a/t/integration/includes/dot-last.tx b/t/integration/includes/dot-last.tx deleted file mode 100644 index b048c5763..000000000 --- a/t/integration/includes/dot-last.tx +++ /dev/null @@ -1,27 +0,0 @@ -use Test2::V0; - -use File::Spec; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -require App::Yath; - -like( - \@INC, - [ - App::Yath->app_path, - File::Spec->catdir($path, 'xyz'), - File::Spec->catdir($path, 'lib'), - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - ], - "Added all via cli, in order" -); - -is($INC[-1], '.', "Dot added last"); - -is($ENV{PERL5LIB}, $ENV{OLD_PERL5LIB}, "PERL5LIB has not been modified"); - -done_testing; diff --git a/t/integration/includes/not-perl.pl b/t/integration/includes/not-perl.pl deleted file mode 100644 index c530fbf88..000000000 --- a/t/integration/includes/not-perl.pl +++ /dev/null @@ -1,35 +0,0 @@ -use Test2::V0; -use File::Spec; -use Config qw/%Config/; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -use App::Yath; - -like( - \@INC, - [ - App::Yath->app_path, - File::Spec->catdir($path, 'xyz'), - File::Spec->catdir($path, 'lib'), - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - ], - "Added all the expected paths in order" -); - -like( - [split $Config{path_sep}, $ENV{PERL5LIB}], - [ - App::Yath->app_path, - File::Spec->catdir($path, 'xyz'), - File::Spec->catdir($path, 'lib'), - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - ], - "When running non-perl the libs were added via PERL5LIB" -); - -done_testing; diff --git a/t/integration/includes/not-perl.sh b/t/integration/includes/not-perl.sh deleted file mode 100755 index 35492231a..000000000 --- a/t/integration/includes/not-perl.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/usr/bin/env bash -exec $YATH_PERL not-perl.pl diff --git a/t/integration/includes/order-ibili.tx b/t/integration/includes/order-ibili.tx deleted file mode 100644 index 466101688..000000000 --- a/t/integration/includes/order-ibili.tx +++ /dev/null @@ -1,32 +0,0 @@ -use Test2::V0; - -use File::Spec; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -require App::Yath; - -like( - \@INC, - [ - App::Yath->app_path, - - File::Spec->catdir($path, 'a'), - - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - - File::Spec->catdir($path, 'b'), - - File::Spec->catdir($path, 'lib'), - - File::Spec->catdir($path, 'c'), - ], - "Added all via cli, in order" -); - -is($ENV{PERL5LIB}, $ENV{OLD_PERL5LIB}, "PERL5LIB has not been modified"); - -done_testing; diff --git a/t/integration/includes/order-ilibi.tx b/t/integration/includes/order-ilibi.tx deleted file mode 100644 index 6abd157f9..000000000 --- a/t/integration/includes/order-ilibi.tx +++ /dev/null @@ -1,32 +0,0 @@ -use Test2::V0; - -use File::Spec; - -my @parts = File::Spec->splitpath(File::Spec->rel2abs(__FILE__)); -pop @parts; -my $path = File::Spec->catpath(@parts); - -require App::Yath; - -like( - \@INC, - [ - App::Yath->app_path, - - File::Spec->catdir($path, 'a'), - - File::Spec->catdir($path, 'lib'), - - File::Spec->catdir($path, 'b'), - - File::Spec->catdir($path, 'blib', 'lib'), - File::Spec->catdir($path, 'blib', 'arch'), - - File::Spec->catdir($path, 'c'), - ], - "Added all via cli, in order" -); - -is($ENV{PERL5LIB}, $ENV{OLD_PERL5LIB}, "PERL5LIB has not been modified"); - -done_testing; diff --git a/t/integration/init.t b/t/integration/init.t deleted file mode 100644 index 28411bcc3..000000000 --- a/t/integration/init.t +++ /dev/null @@ -1,38 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; -use Cwd qw/cwd/; - -use App::Yath::Tester qw/yath/; -use App::Yath::Util qw/find_yath/; -find_yath(); # cache result before we chdir - -my $orig = cwd(); -my $dir = tempdir(CLEANUP => 1); -chdir($dir); - -yath( - command => 'init', - args => [], - exit => 0, - test => sub { - like($_, qr/Writing test\.pl/, "Short message"); - - ok(-e 'test.pl', "Added test.pl"); - - open(my $fh, '<', 'test.pl') or die $!; - my $found = 0; - while (my $line = <$fh>) { - next unless $line =~ m/THIS IS A GENERATED YATH RUNNER TEST/; - $found++; - last; - } - - ok($found, "Found generated note"); - }, -); - -chdir($orig); - -done_testing; diff --git a/t/integration/log_dir.t b/t/integration/log_dir.t deleted file mode 100644 index 45b1ec7ae..000000000 --- a/t/integration/log_dir.t +++ /dev/null @@ -1,34 +0,0 @@ -use Test2::V0; - -use App::Yath::Tester qw/yath/; -use File::Temp qw/tempdir/; - -use File::Spec; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my $tmpdir = tempdir(CLEANUP => 1); - -yath( - command => 'test', - args => ["--log-dir=$tmpdir", '-L', '--ext=tx', $dir], - exit => 0, - test => sub { - my $out = shift; - - opendir(my $dh, $tmpdir) or die "Could not open dir $tmpdir: $!"; - my @files; - for my $file (readdir($dh)) { - next if $file =~ m/^\.+$/; - next unless -f File::Spec->catfile($tmpdir, $file); - push @files => $file; - } - - is(@files, 1, "Only 1 file present"); - like($files[0], qr{\.jsonl$}, "File is a jsonl file"); - }, -); - -done_testing; diff --git a/t/integration/log_dir/foo.tx b/t/integration/log_dir/foo.tx deleted file mode 100644 index 84bb1b356..000000000 --- a/t/integration/log_dir/foo.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; diff --git a/t/integration/persist.t b/t/integration/persist.t deleted file mode 100644 index aebc43091..000000000 --- a/t/integration/persist.t +++ /dev/null @@ -1,100 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -skip_all "This test is not run under automated testing" - if $ENV{AUTOMATED_TESTING}; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath(command => 'start', exit => 0); - -yath( - command => 'run', - args => [$dir, '--ext=tx', '--ext=txx'], - exit => T(), - test => sub { - my $out = shift; - like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - - -yath( - command => 'run', - args => [$dir, '--ext=tx'], - exit => 0, - test => sub { - my $out = shift; - unlike($out->{output}, qr{fail\.tx}, "'fail.tx' was not seen when reading the output"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -yath( - command => 'which', - exit => 0, - test => sub { - my $out = shift; - like($out->{output}, qr/^\s*Found: .*yath-persist\.json$/m, "Found the persist file"); - like($out->{output}, qr/^\s*PID: /m, "Found the PID"); - like($out->{output}, qr/^\s*Dir: /m, "Found the Dir"); - }, -); - -yath(command => 'reload', exit => 0); - -yath( - command => 'watch', - args => ['STOP'], - exit => 0, - test => sub { - my $out = shift; - like($out->{output}, qr{yath-nested-runner \(default\) Runner caught SIGHUP, reloading}, "Reloaded runner"); - }, -); - -yath( - command => 'run', - args => [$dir, '--ext=txx'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output"); - unlike($out->{output}, qr{pass\.tx}, "'pass.tx' was not seen when reading the output"); - }, -); - -yath( - command => 'run', - args => [$dir, '-vvv'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr/No tests were seen!/, "Got error message"); - }, -); - -yath(command => 'stop', exit => 0); - -yath( - command => 'which', - exit => 0, - test => sub { - my $out = shift; - like($out->{output}, qr/No persistent harness was found for the current path\./, "No active runner"); - }, -); - -done_testing; diff --git a/t/integration/persist/fail.txx b/t/integration/persist/fail.txx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/persist/fail.txx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/persist/pass.tx b/t/integration/persist/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/persist/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/plugin.t b/t/integration/plugin.t deleted file mode 100644 index 293df6ef5..000000000 --- a/t/integration/plugin.t +++ /dev/null @@ -1,90 +0,0 @@ -use Test2::V0; - -use App::Yath::Tester qw/yath/; -use File::Temp qw/tempdir/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -sub verify { - my (@outputs) = @_; - - my $text = ''; - for my $out (@outputs) { - $text .= $out->{output}; - } - - like($text, qr/TEST PLUGIN: Loaded Plugin/, "Yath loaded the plugin"); - like($text, qr/TEST PLUGIN: duration_data/, "duration_data() was called"); - - like($text, qr/TEST PLUGIN: changed_files\(Test2::Harness::Settings\)/, "changed_files() was called"); - like($text, qr/TEST PLUGIN: get_coverage_tests\(Test2::Harness::Settings, HASH\(5\)\)/, "get_coverage_tests() was called"); - - like($text, qr/TEST PLUGIN: munge_files/, "munge_files() was called"); - like($text, qr/TEST PLUGIN: munge_search/, "munge_search() was called"); - like($text, qr/TEST PLUGIN: inject_run_data/, "inject_run_data() was called"); - like($text, qr/TEST PLUGIN: handle_event/, "handle_event() was called"); - - like($text, qr/TEST PLUGIN: claim_file .*test\.tx$/m, "claim_file(test.tx) was called"); - like($text, qr/TEST PLUGIN: claim_file .*TestPlugin\.pm$/m, "claim_file(TestPlugin.pm) was called"); - like($text, qr/TEST PLUGIN: setup Test2::Harness::Settings/, "setup() was called with settings"); - like($text, qr/TEST PLUGIN: teardown Test2::Harness::Settings/, "teardown() was called with settings"); - - like($text, qr/\(TESTPLUG\)\s+STDERR WRITE$/m, "Got the STDERR write from the shellcall"); - like($text, qr/\(TESTPLUG\)\s+STDOUT WRITE$/m, "Got the STDOUT write from the shellcall"); - - like( - $text, - qr/TEST PLUGIN: finish asserts_seen => 10, final_data => HASH, pass => 1, settings => Test2::Harness::Settings, tests_seen => 5/, - "finish() was called with necessary args" - ); - - is(@{[$text =~ m/TEST PLUGIN: setup/g]}, 1, "Only ran setup once"); - is(@{[$text =~ m/TEST PLUGIN: teardown/g]}, 1, "Only ran teardown once"); - is(@{[$text =~ m/TEST PLUGIN: finish/g]}, 1, "Only ran finish once"); - - if (ok($text =~ m/^FIELDS:(.*)$/m, "Found fields")) { - my $data = decode_json($1); - is( - $data, - [{ - name => 'test_plugin', details => 'foo', raw => 'bar', data => 'baz', - }], - "Injected the run data" - ); - } - - my %rank = ( - test => 1, - c => 2, - b => 3, - a => 4, - d => 5, - ); - - my %jobs = reverse($text =~ m{job\s+(\d+)\s+.*\W(\w+)\.tx}g); - is(\%jobs, \%rank, "Ran jobs in specified order"); -} - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-A', '--durations-threshold' => 1, '--no-plugins', '-pTestPlugin', '--changes-plugin', 'TestPlugin'], - exit => 0, - test => \&verify, -); - -unless ($ENV{AUTOMATED_TESTING} || $ENV{AUTHOR_TESTING}) { - subtest persist => sub { - verify( - yath(command => 'start', args => ['--no-plugins', '-pTestPlugin'], exit => 0), - yath(command => 'run', args => ['--no-plugins', '-pTestPlugin', '--changes-plugin', 'TestPlugin', exit => 0, $dir, '--ext=tx', '-A']), - yath(command => 'stop', args => ['--no-plugins', '-pTestPlugin'], exit => 0), - ); - }; -} - -done_testing; diff --git a/t/integration/plugin/a.tx b/t/integration/plugin/a.tx deleted file mode 100644 index 0c642d50d..000000000 --- a/t/integration/plugin/a.tx +++ /dev/null @@ -1,4 +0,0 @@ -use Test2::V0; -ok(1); -is($ENV{T2_HARNESS_JOB_DURATION}, 'short'); -done_testing; diff --git a/t/integration/plugin/b.tx b/t/integration/plugin/b.tx deleted file mode 100644 index 9889296d8..000000000 --- a/t/integration/plugin/b.tx +++ /dev/null @@ -1,4 +0,0 @@ -use Test2::V0; -ok(1); -is($ENV{T2_HARNESS_JOB_DURATION}, 'medium'); -done_testing; diff --git a/t/integration/plugin/c.tx b/t/integration/plugin/c.tx deleted file mode 100644 index 9889296d8..000000000 --- a/t/integration/plugin/c.tx +++ /dev/null @@ -1,4 +0,0 @@ -use Test2::V0; -ok(1); -is($ENV{T2_HARNESS_JOB_DURATION}, 'medium'); -done_testing; diff --git a/t/integration/plugin/d.tx b/t/integration/plugin/d.tx deleted file mode 100644 index f4a855cfc..000000000 --- a/t/integration/plugin/d.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; -ok(1); - -is($ENV{T2_HARNESS_JOB_DURATION}, 'medium'); - -done_testing; diff --git a/t/integration/plugin/lib/App/Yath/Plugin/TestPlugin.pm b/t/integration/plugin/lib/App/Yath/Plugin/TestPlugin.pm deleted file mode 100644 index c4f270175..000000000 --- a/t/integration/plugin/lib/App/Yath/Plugin/TestPlugin.pm +++ /dev/null @@ -1,187 +0,0 @@ -package App::Yath::Plugin::TestPlugin; -use strict; -use warnings; - -use Test2::Harness::Util::HashBase qw/-foo/; -use Test2::Harness::Util::JSON qw/encode_json/; - -use Scalar::Util qw/blessed/; - -use parent 'App::Yath::Plugin'; - -print "TEST PLUGIN: Loaded Plugin\n"; - -sub duration_data { - my $self = shift; - - print "TEST PLUGIN: duration_data\n"; - - return { - 't/integration/plugin/a.tx' => 'short', - 't/integration/plugin/b.tx' => 'medium', - 't/integration/plugin/c.tx' => 'medium', - 't/integration/plugin/d.tx' => 'medium', - 't/integration/plugin/test.tx' => 'long', - }; -} - -sub get_coverage_tests { - my $self = shift; - my ($settings, $changes) = @_; - - my $stype = ref($settings); - my $type = ref($changes); - my $count = keys %$changes; - - print "TEST PLUGIN: get_coverage_tests($stype, $type($count))\n"; - - return [ - 't/integration/plugin/a.tx', - 't/integration/plugin/b.tx', - 't/integration/plugin/c.tx', - 't/integration/plugin/d.tx', - 't/integration/plugin/test.tx', - ]; -} - -sub changed_files { - my $self = shift; - my ($settings) = @_; - my $type = ref($settings); - - print "TEST PLUGIN: changed_files($type)\n"; - - return ( - 't/integration/plugin/a.tx', - 't/integration/plugin/b.tx', - 't/integration/plugin/c.tx', - 't/integration/plugin/d.tx', - 't/integration/plugin/test.tx', - ); -} - -sub sort_files_2 { - my $self = shift; - my %params = @_; - - die "self is not an instance! ($self)" unless blessed($self); - - my $settings = $params{settings} or die "NO SETTINGS!"; - my $files = $params{files}; - - my %rank = ( - test => 1, - c => 2, - b => 3, - a => 4, - d => 5, - ); - - my @files = sort { - my $an = $a->file; - my $bn = $b->file; - $an =~ s/^.*\W(\w+)\.tx$/$1/; - $bn =~ s/^.*\W(\w+)\.tx$/$1/; - $rank{$an} <=> $rank{$bn}; - } @$files; - - return @files; -}; - -sub munge_files { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - print "TEST PLUGIN: munge_files\n"; - return; -} - -sub munge_search { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my ($search, $default_search) = @_; - - print "TEST PLUGIN: munge_search\n"; - - @$search = (); - - my $path = __FILE__; - $path =~ s{lib.{1,2}App.{1,2}Yath.{1,2}Plugin.{1,2}TestPlugin\.pm$}{}g; - - @$default_search = ($path); - - return; -} - -sub claim_file { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my ($file) = @_; - print "TEST PLUGIN: claim_file $file\n"; - - if ($file =~ /\.tx/) { - require Test2::Harness::TestFile; - return Test2::Harness::TestFile->new(file => $file); - } - - return; -} - -sub inject_run_data { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my %params = @_; - print "TEST PLUGIN: inject_run_data\n"; - - my $fields = $params{fields}; - push @$fields => {name => 'test_plugin', details => 'foo', raw => 'bar', data => 'baz'}; - - return; -} - -my $seen = 0; -sub handle_event { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my ($event) = @_; - print "TEST PLUGIN: handle_event\n" unless $seen++; - - if(my $run = $event->facet_data->{harness_run}) { - print "FIELDS: " . encode_json($run->{fields}) . "\n"; - } - - return; -} - -sub finish { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my %args = @_; - - print "TEST PLUGIN: finish " . join(', ' => map { "$_ => " . (ref($args{$_}) || $args{$_} // '?') } sort keys %args) . "\n"; - return; -} - -sub setup { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my ($settings) = @_; - print "TEST PLUGIN: setup " . ref($settings) . "\n"; - - $self->shellcall( - $settings, - 'testplug', - $^X, '-e', 'print STDERR "STDERR WRITE\n"; print STDOUT "STDOUT WRITE\n";', - ); - - return; -} - -sub teardown { - my $self = shift; - die "self is not an instance! ($self)" unless blessed($self); - my ($settings) = @_; - print "TEST PLUGIN: teardown " . ref($settings) . "\n"; - return; -} - -1; diff --git a/t/integration/plugin/test.tx b/t/integration/plugin/test.tx deleted file mode 100644 index 5a5b896c4..000000000 --- a/t/integration/plugin/test.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -ok(!$INC{'App/Yath/Plugin/TestPlugin.pm'}, "Plugin is not loaded for test processes"); - -is($ENV{T2_HARNESS_JOB_DURATION}, 'long'); - -done_testing(); diff --git a/t/integration/preload.t b/t/integration/preload.t deleted file mode 100644 index e83e4420b..000000000 --- a/t/integration/preload.t +++ /dev/null @@ -1,127 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -use Test2::Util qw/CAN_REALLY_FORK/; - -skip_all "Cannot fork, skipping preload test" - unless CAN_REALLY_FORK; - -skip_all "This test requires forking" if $ENV{T2_NO_FORK}; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-A', '-PTestSimplePreload', '-PTestPreload'], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{PASSED.*no_preload\.tx}, 'Ran file "no_preload.tx"'); - like($out->{output}, qr{PASSED.*aaa\.tx}, 'Ran file "aaa.tx"'); - like($out->{output}, qr{PASSED.*bbb\.tx}, 'Ran file "bbb.tx"'); - like($out->{output}, qr{PASSED.*ccc\.tx}, 'Ran file "ccc.tx"'); - like($out->{output}, qr{PASSED.*simple_test\.tx}, 'Ran file "simple_test.tx"'); - like($out->{output}, qr{PASSED.*preload_test\.tx}, 'Ran file "preload_test.tx"'); - like($out->{output}, qr{PASSED.*fast\.tx}, 'Ran file "fast.tx"'); - like($out->{output}, qr{PASSED.*slow\.tx}, 'Ran file "slow.tx"'); - like($out->{output}, qr{TO RETRY.*retry\.tx}, 'Ran file "retry.tx" with a failure'); - like($out->{output}, qr{PASSED.*retry\.tx}, 'Ran file "retry.tx" again with a pass'); - }, -); - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-A', '-PTestSimplePreload', '-PTestPreload', '-PBroken'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{This is broken}, "Reported the error"); - like($out->{output}, qr{No tests were seen!}, "No tests were run"); - }, -); - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-A', '-PTestBadPreload' ], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{Child stage 'BAD' did not exit cleanly}, "Reported the error"); - }, -); - -unless ($ENV{AUTOMATED_TESTING}) { - yath( - command => 'start', - args => ['-PTestSimplePreload', '-PTestPreload'], - exit => 0, - test => sub { - yath( - command => 'run', - args => [$dir, '--ext=tx', '-A'], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{PASSED.*no_preload\.tx}, 'Ran file "no_preload.tx"'); - like($out->{output}, qr{PASSED.*aaa\.tx}, 'Ran file "aaa.tx"'); - like($out->{output}, qr{PASSED.*bbb\.tx}, 'Ran file "bbb.tx"'); - like($out->{output}, qr{PASSED.*ccc\.tx}, 'Ran file "ccc.tx"'); - like($out->{output}, qr{PASSED.*simple_test\.tx}, 'Ran file "simple_test.tx"'); - like($out->{output}, qr{PASSED.*preload_test\.tx}, 'Ran file "preload_test.tx"'); - like($out->{output}, qr{PASSED.*fast\.tx}, 'Ran file "fast.tx"'); - like($out->{output}, qr{PASSED.*slow\.tx}, 'Ran file "slow.tx"'); - like($out->{output}, qr{TO RETRY.*retry\.tx}, 'Ran file "retry.tx" with a failure'); - like($out->{output}, qr{PASSED.*retry\.tx}, 'Ran file "retry.tx" again with a pass'); - }, - ); - - yath(command => 'stop', exit => 0); - }, - ); - - # Persistent mode ignored broken preloads as they may be under active development - yath( - command => 'start', - args => ['-PTestSimplePreload', '-PTestPreload', '-PBroken'], - exit => 0, - test => sub { - yath( - command => 'run', - args => [$dir, '--ext=tx', '-A'], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{This is broken}, "Reported the error"); - like($out->{output}, qr{PASSED.*no_preload\.tx}, 'Ran file "no_preload.tx"'); - like($out->{output}, qr{PASSED.*aaa\.tx}, 'Ran file "aaa.tx"'); - like($out->{output}, qr{PASSED.*bbb\.tx}, 'Ran file "bbb.tx"'); - like($out->{output}, qr{PASSED.*ccc\.tx}, 'Ran file "ccc.tx"'); - like($out->{output}, qr{PASSED.*simple_test\.tx}, 'Ran file "simple_test.tx"'); - like($out->{output}, qr{PASSED.*preload_test\.tx}, 'Ran file "preload_test.tx"'); - like($out->{output}, qr{PASSED.*fast\.tx}, 'Ran file "fast.tx"'); - like($out->{output}, qr{PASSED.*slow\.tx}, 'Ran file "slow.tx"'); - like($out->{output}, qr{TO RETRY.*retry\.tx}, 'Ran file "retry.tx" with a failure'); - like($out->{output}, qr{PASSED.*retry\.tx}, 'Ran file "retry.tx" again with a pass'); - }, - ); - - yath(command => 'stop', exit => 0); - }, - ); -} - -done_testing; diff --git a/t/integration/preload/aaa.tx b/t/integration/preload/aaa.tx deleted file mode 100644 index 4aac9fbad..000000000 --- a/t/integration/preload/aaa.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -is($ENV{T2_HARNESS_STAGE}, 'AAA', "Running in stage 'AAA'"); -ok($INC{'AAA.pm'}, "Preloaded AAA"); - -done_testing; diff --git a/t/integration/preload/bbb.tx b/t/integration/preload/bbb.tx deleted file mode 100644 index e34974e8b..000000000 --- a/t/integration/preload/bbb.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -is($ENV{T2_HARNESS_STAGE}, 'BBB', "Running in stage 'BBB'"); -ok($INC{'BBB.pm'}, "Preloaded BBB"); - -done_testing; diff --git a/t/integration/preload/ccc.tx b/t/integration/preload/ccc.tx deleted file mode 100644 index 2479da6a6..000000000 --- a/t/integration/preload/ccc.tx +++ /dev/null @@ -1,31 +0,0 @@ -use Test2::V0; -#HARNESS-STAGE-CCC - -is($ENV{T2_HARNESS_STAGE}, 'CCC', "Running in stage 'CCC'"); -ok($INC{'CCC.pm'}, "Preloaded CCC"); - -is( - [sort { $TestPreload::HOOKS{$a}->[0] <=> $TestPreload::HOOKS{$b}->[0] } keys %TestPreload::HOOKS], - [qw/INIT PRE_FORK POST_FORK PRE_LAUNCH/], - "Hooks happened in order" -); - -is( - $TestPreload::HOOKS{POST_FORK}->[1], - $TestPreload::HOOKS{PRE_LAUNCH}->[1], - "POST_FORK and PRE_LAUNCH happened in the same PID" -); - -isnt( - $TestPreload::HOOKS{POST_FORK}->[1], - $TestPreload::HOOKS{INIT}->[1], - "POST_FORK and INIT are not in the same PID" -); - -isnt( - $TestPreload::HOOKS{POST_FORK}->[1], - $TestPreload::HOOKS{PRE_FORK}->[1], - "POST_FORK and PRE_FORK are not in the same PID" -); - -done_testing; diff --git a/t/integration/preload/fast.tx b/t/integration/preload/fast.tx deleted file mode 100644 index e4494068f..000000000 --- a/t/integration/preload/fast.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok($INC{'FAST.pm'}, "Preloaded fast"); -is($ENV{T2_HARNESS_STAGE}, 'FAST', "Running in 'FAST' stage"); - -done_testing; diff --git a/t/integration/preload/lib/AAA.pm b/t/integration/preload/lib/AAA.pm deleted file mode 100644 index 0357e63fb..000000000 --- a/t/integration/preload/lib/AAA.pm +++ /dev/null @@ -1,2 +0,0 @@ -package AAA; -1; diff --git a/t/integration/preload/lib/BBB.pm b/t/integration/preload/lib/BBB.pm deleted file mode 100644 index 2cb39c645..000000000 --- a/t/integration/preload/lib/BBB.pm +++ /dev/null @@ -1,2 +0,0 @@ -package BBB; -1; diff --git a/t/integration/preload/lib/Broken.pm b/t/integration/preload/lib/Broken.pm deleted file mode 100644 index 0de0937fe..000000000 --- a/t/integration/preload/lib/Broken.pm +++ /dev/null @@ -1,3 +0,0 @@ -package Broken; - -die "This is broken"; diff --git a/t/integration/preload/lib/CCC.pm b/t/integration/preload/lib/CCC.pm deleted file mode 100644 index e0b9a33a6..000000000 --- a/t/integration/preload/lib/CCC.pm +++ /dev/null @@ -1,2 +0,0 @@ -package CCC; -1; diff --git a/t/integration/preload/lib/FAST.pm b/t/integration/preload/lib/FAST.pm deleted file mode 100644 index 51c7507d6..000000000 --- a/t/integration/preload/lib/FAST.pm +++ /dev/null @@ -1,2 +0,0 @@ -package FAST; -1; diff --git a/t/integration/preload/lib/TestBadPreload.pm b/t/integration/preload/lib/TestBadPreload.pm deleted file mode 100644 index 83dbef979..000000000 --- a/t/integration/preload/lib/TestBadPreload.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestBadPreload; -use strict; -use warnings; - -use Test2::Harness::Runner::Preload; - -stage BAD => sub { - default; - preload "Test2::Harness::Preload::Does::Not::Exist"; -}; - -1; diff --git a/t/integration/preload/lib/TestPreload.pm b/t/integration/preload/lib/TestPreload.pm deleted file mode 100644 index 52cc9de5f..000000000 --- a/t/integration/preload/lib/TestPreload.pm +++ /dev/null @@ -1,72 +0,0 @@ -package TestPreload; -use strict; -use warnings; -use Time::HiRes qw/sleep time/; -use File::Temp qw/tempdir/; -use File::Spec; - -use Test2::Harness::Runner::Preload; - -my $dir = tempdir(CLEANUP => 1); -my $TRIGGER = File::Spec->catfile($dir, 'trigger'); - -file_stage sub { - my ($file) = @_; - - return uc($1) if $file =~ m/(AAA|BBB)\.tx$/i; - - return; -}; - -stage AAA => sub { - preload 'AAA'; - - stage BBB => sub { - preload 'BBB'; - }; -}; - -our %HOOKS; -stage CCC => sub { - $HOOKS{INIT} = [time(), $$]; - pre_fork sub { $HOOKS{PRE_FORK} = [time(), $$] }; - post_fork sub { $HOOKS{POST_FORK} = [time(), $$] }; - pre_launch sub { $HOOKS{PRE_LAUNCH} = [time(), $$] }; - - preload 'CCC'; -}; - -stage FAST => sub { - eager; - default; - - preload 'FAST'; - - preload sub { - eval <<" EOT" or die $@; -#line ${ \__LINE__ } "${ \__FILE__ }" -END { - return unless \$0 =~ m/slow\.tx/; - open(my \$fh, '>', "$TRIGGER") or die "XXX"; - print \$fh "\n"; - close(\$fh); -} -1; - EOT - }; - - stage SLOW => sub { - preload sub { - print "$0 pending...\n"; - use Carp qw/cluck/; - local $SIG{ALRM} = sub { cluck "oops"; exit 255 }; - alarm 5; - until (-f $TRIGGER) { - print "$0 Waiting...\n"; - sleep 0.2 - } - }; - }; -}; - -1; diff --git a/t/integration/preload/lib/TestSimplePreload.pm b/t/integration/preload/lib/TestSimplePreload.pm deleted file mode 100644 index b99960c70..000000000 --- a/t/integration/preload/lib/TestSimplePreload.pm +++ /dev/null @@ -1,3 +0,0 @@ -package TestSimplePreload; - -1; diff --git a/t/integration/preload/no_preload.tx b/t/integration/preload/no_preload.tx deleted file mode 100644 index 0b52c8c3c..000000000 --- a/t/integration/preload/no_preload.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; -# HARNESS-NO-PRELOAD - -is($ENV{T2_HARNESS_STAGE}, 'NOPRELOAD', "Running in 'NOPRELOAD' stage"); - -done_testing; diff --git a/t/integration/preload/preload_test.tx b/t/integration/preload/preload_test.tx deleted file mode 100644 index e526409ea..000000000 --- a/t/integration/preload/preload_test.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok($INC{'TestPreload.pm'}, "Preload is loaded"); - -done_testing; diff --git a/t/integration/preload/retry.tx b/t/integration/preload/retry.tx deleted file mode 100644 index 63423768d..000000000 --- a/t/integration/preload/retry.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; -#HARNESS-RETRY - -ok($ENV{T2_HARNESS_JOB_IS_TRY}, "This is a retry"); - -done_testing; diff --git a/t/integration/preload/simple_test.tx b/t/integration/preload/simple_test.tx deleted file mode 100644 index f6e525754..000000000 --- a/t/integration/preload/simple_test.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok($INC{'TestSimplePreload.pm'}, "Preload is loaded"); - -done_testing; diff --git a/t/integration/preload/slow.tx b/t/integration/preload/slow.tx deleted file mode 100644 index c5cec630f..000000000 --- a/t/integration/preload/slow.tx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; -#HARNESS-STAGE-SLOW - -ok($INC{'FAST.pm'}, "Preloaded fast"); -is($ENV{T2_HARNESS_STAGE}, 'FAST', "Running in 'FAST' stage despite asking for 'SLOW'"); - -done_testing; diff --git a/t/integration/projects.t b/t/integration/projects.t deleted file mode 100644 index c797b38f8..000000000 --- a/t/integration/projects.t +++ /dev/null @@ -1,77 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Util qw/find_yath/; -find_yath(); # cache result before we chdir - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my $out; - -yath( - command => 'projects', - args => ['--ext=tx', '--', $dir], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{PASSED .*foo.*t.*pass\.tx}, "Found pass.tx in foo project"); - like($out->{output}, qr{PASSED .*bar.*t.*pass\.tx}, "Found pass.tx in bar project"); - like($out->{output}, qr{PASSED .*baz.*t.*pass\.tx}, "Found pass.tx in baz project"); - unlike($out->{output}, qr{fail\.txx}, "Did not run fail.txx"); - }, -); - -yath( - command => 'projects', - args => ['--ext=tx', '--ext=txx', '--', $dir], - exit => T(), - test => sub { - my $out = shift; - like($out->{output}, qr{PASSED .*foo.*t.*pass\.tx}, "Found pass.tx in foo project"); - like($out->{output}, qr{PASSED .*bar.*t.*pass\.tx}, "Found pass.tx in bar project"); - like($out->{output}, qr{PASSED .*baz.*t.*pass\.tx}, "Found pass.tx in baz project"); - like($out->{output}, qr{FAILED .*baz.*t.*fail\.txx}, "ran fail.txx"); - }, -); - -chdir($dir); - -yath( - command => 'projects', - args => ['--ext=tx', '-v'], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{PASSED .*foo.*t.*pass\.tx}, "Found pass.tx in foo project"); - like($out->{output}, qr{PASSED .*bar.*t.*pass\.tx}, "Found pass.tx in bar project"); - like($out->{output}, qr{PASSED .*baz.*t.*pass\.tx}, "Found pass.tx in baz project"); - unlike($out->{output}, qr{fail\.txx}, "Did not run fail.txx"); - }, -); - -yath( - command => 'projects', - args => ['--ext=tx', '--ext=txx'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{PASSED .*foo.*t.*pass\.tx}, "Found pass.tx in foo project"); - like($out->{output}, qr{PASSED .*bar.*t.*pass\.tx}, "Found pass.tx in bar project"); - like($out->{output}, qr{PASSED .*baz.*t.*pass\.tx}, "Found pass.tx in baz project"); - like($out->{output}, qr{FAILED .*baz.*t.*fail\.txx}, "ran fail.txx"); - }, -); - -done_testing; diff --git a/t/integration/projects/bar/lib/Bar.pm b/t/integration/projects/bar/lib/Bar.pm deleted file mode 100644 index 9658195a7..000000000 --- a/t/integration/projects/bar/lib/Bar.pm +++ /dev/null @@ -1,3 +0,0 @@ -package Bar; - -1; diff --git a/t/integration/projects/bar/lib/Baz.pm b/t/integration/projects/bar/lib/Baz.pm deleted file mode 100644 index 9eaae14f8..000000000 --- a/t/integration/projects/bar/lib/Baz.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Baz.pm from the wrong project!"; diff --git a/t/integration/projects/bar/lib/Foo.pm b/t/integration/projects/bar/lib/Foo.pm deleted file mode 100644 index 3c7aba5cc..000000000 --- a/t/integration/projects/bar/lib/Foo.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Foo.pm from the wrong project!"; diff --git a/t/integration/projects/bar/t/pass.tx b/t/integration/projects/bar/t/pass.tx deleted file mode 100644 index 930253c9a..000000000 --- a/t/integration/projects/bar/t/pass.tx +++ /dev/null @@ -1,11 +0,0 @@ -use Test2::V0; -use Bar; - -is(__FILE__, 't/pass.tx', "__FILE__ is set correctly"); - -like(dies { require Foo }, qr{Loaded Foo.pm from the wrong project}, "Using our own libs (Foo)"); -like(dies { require Baz }, qr{Loaded Baz.pm from the wrong project}, "Using our own libs (Baz)"); - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/projects/baz/lib/Bar.pm b/t/integration/projects/baz/lib/Bar.pm deleted file mode 100644 index fe3109e31..000000000 --- a/t/integration/projects/baz/lib/Bar.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Bar.pm from the wrong project!"; diff --git a/t/integration/projects/baz/lib/Baz.pm b/t/integration/projects/baz/lib/Baz.pm deleted file mode 100644 index 695063b19..000000000 --- a/t/integration/projects/baz/lib/Baz.pm +++ /dev/null @@ -1,3 +0,0 @@ -package Baz; - -1; diff --git a/t/integration/projects/baz/lib/Foo.pm b/t/integration/projects/baz/lib/Foo.pm deleted file mode 100644 index 3c7aba5cc..000000000 --- a/t/integration/projects/baz/lib/Foo.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Foo.pm from the wrong project!"; diff --git a/t/integration/projects/baz/t/fail.txx b/t/integration/projects/baz/t/fail.txx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/projects/baz/t/fail.txx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/projects/baz/t/pass.tx b/t/integration/projects/baz/t/pass.tx deleted file mode 100644 index 94d2be7e8..000000000 --- a/t/integration/projects/baz/t/pass.tx +++ /dev/null @@ -1,11 +0,0 @@ -use Test2::V0; -use Baz; - -is(__FILE__, 't/pass.tx', "__FILE__ is set correctly"); - -like(dies { require Foo }, qr{Loaded Foo.pm from the wrong project}, "Using our own libs (Foo)"); -like(dies { require Bar }, qr{Loaded Bar.pm from the wrong project}, "Using our own libs (Bar)"); - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/projects/foo/lib/Bar.pm b/t/integration/projects/foo/lib/Bar.pm deleted file mode 100644 index fe3109e31..000000000 --- a/t/integration/projects/foo/lib/Bar.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Bar.pm from the wrong project!"; diff --git a/t/integration/projects/foo/lib/Baz.pm b/t/integration/projects/foo/lib/Baz.pm deleted file mode 100644 index 9eaae14f8..000000000 --- a/t/integration/projects/foo/lib/Baz.pm +++ /dev/null @@ -1 +0,0 @@ -die "Loaded Baz.pm from the wrong project!"; diff --git a/t/integration/projects/foo/lib/Foo.pm b/t/integration/projects/foo/lib/Foo.pm deleted file mode 100644 index 04f9965eb..000000000 --- a/t/integration/projects/foo/lib/Foo.pm +++ /dev/null @@ -1,3 +0,0 @@ -package Foo; - -1; diff --git a/t/integration/projects/foo/t/pass.tx b/t/integration/projects/foo/t/pass.tx deleted file mode 100644 index 04920f2b1..000000000 --- a/t/integration/projects/foo/t/pass.tx +++ /dev/null @@ -1,11 +0,0 @@ -use Test2::V0; -use Foo; - -is(__FILE__, 't/pass.tx', "__FILE__ is set correctly"); - -like(dies { require Bar }, qr{Loaded Bar.pm from the wrong project}, "Using our own libs (Bar)"); -like(dies { require Baz }, qr{Loaded Baz.pm from the wrong project}, "Using our own libs (Baz)"); - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/reload.t b/t/integration/reload.t deleted file mode 100644 index 9493dbaac..000000000 --- a/t/integration/reload.t +++ /dev/null @@ -1,455 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; -use Test2::Harness::Util qw/clean_path/; - -use Test2::Harness::Util::JSON qw/decode_json/; - -skip_all "This test is not run under automated testing" - if $ENV{AUTOMATED_TESTING}; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; -my $fqdir = clean_path($dir); -my $pdir = $fqdir; -$pdir =~ s{\W{0,2}t\W{1,2}integration\W{1,2}reload$}{}g; - -my $tmpdir = tempdir(CLEANUP => 1); -mkdir("$tmpdir/Preload") or die "($tmpdir/Preload) $!"; - -sub touch_files { - note "About to touch files with a delay between each, this will take a while"; - - for my $file (qw/A B A B ExceptionA ExceptionB WarningA WarningB ExporterA ExporterB IncChange Churn nonperl1 nonperl2/) { - my $path = "$dir/lib/Preload/${file}"; - $path .= '.pm' unless $file =~ m/nonperl/; - note "Touching $file..."; - sleep 2; - - if ($file eq 'IncChange') { - open(my $fh, '>', "$tmpdir/Preload/IncChange.pm") or die $!; - - print $fh <<' EOT'; -package Preload::IncChange; -use strict; -use warnings; - -BEGIN { - print "$$ $0 Loaded (DIFFERENT) ${ \__PACKAGE__ }\n"; -} - -1; - EOT - - close($fh); - } - - utime(undef, undef, $path); - } - - sleep 2; -} - -sub parse_output { - my ($output) = @_; - - # On macOS, these days, /var is actually a symlink to /private/var. - # Somewhere along the lines, something is turning /var into /private/var in - # the runner, which makes the "strip out the tmpdir" code (marked below) - # leave behind a /private. This fix is inelegant, but probably fixes the - # overwhelming majority of macOS test failures without introducing any - # further problems. A better fix might be to track down and eliminate the - # rewriting of the path, or to uniformly make this check match the behavior - # under the hood. For now: let's just let macOS users install - # TAP2::Harness! -- rjbs, 2022-02-20 - my $safe_tmpdir = $tmpdir; - if ($safe_tmpdir =~ m{\A/var/} && -l '/var') { - my $target = File::Spec->rel2abs(readlink('/var'), '/'); - $target =~ s{/\z}{}; - $safe_tmpdir =~ s{\A/var}{$target}; - } - - my %by_proc; - for my $line (split /\n/, $output) { - next unless $line =~ m/^\s*(\d+) yath-nested-runner(?:-(\S+))? - (.+)$/; - my ($pid, $proc, $text) = ($1, $2, $3); - $proc //= ''; - $text =~ s/$pid yath-nested-runner-$proc(\s*-\s*)//g; - $text =~ s{(\Q$fqdir\E|\Q$dir\E|\Q$pdir\E)/*}{}g; - - $text =~ s{\Q$safe_tmpdir\E(/)?}{TEMP$1}g; # <-- strip out the tmpdir - - $text =~ s{ line \d+.*$}{}g; - push @{$by_proc{$proc || 'default'}} => $text; - } - - return \%by_proc; -} - -subtest no_in_place => sub { - unlink("$tmpdir/Preload/IncChange.pm") if -e "$tmpdir/Preload/IncChange.pm"; - - yath( - command => 'start', - args => ['-PPreload'], - pre => ["-D$tmpdir"], - exit => 0, - ); - - touch_files(); - - yath( - command => 'watch', - args => ['STOP'], - exit => 0, - test => sub { - my $out = shift; - - my $parsed = parse_output($out->{output}); - is( - $parsed, - { - 'default' => [ - 'Loaded Preload', - ], - 'A' => [ - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::A...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExceptionA...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExporterA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::WarningA...', - 'Loaded Preload::ExporterA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterA...', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/Churn.pm\'...', - 'Changed file \'Preload/Churn.pm\' contains churn sections, running them instead of a full reload...', - 'Churn 1', - 'FOO: foo 2', - 'Success reloading churn block (lib/Preload/Churn.pm lines 8 -> 16)', - 'Churn 2', - 'Success reloading churn block (lib/Preload/Churn.pm lines 18 -> 20)', - 'Error reloading churn block (lib/Preload/Churn.pm lines 22 -> 28): Died on count 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/nonperl1\'...', - 'Changed file \'lib/Preload/nonperl1\' has a reload callback, executing it instead of regular reloading...', - 'RELOAD CALLBACK nonperl1', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/nonperl2\'...', - 'Changed file \'lib/Preload/nonperl2\' has a reload callback, executing it instead of regular reloading...', - 'RELOAD CALLBACK nonperl2', - ], - 'B' => [ - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::B', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::A...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::B', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/B.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::B...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExceptionA...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionB.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExceptionB...', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::WarningA...', - 'Loaded Preload::ExporterA', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningB.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::WarningB...', - 'Loaded Preload::ExporterA', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterA...', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterB.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterB...', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/IncChange.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::IncChange...', - ], - }, - "Reload happened as expected", - ); - }, - ); - - yath(command => 'stop', exit => 0); -}; - -subtest in_place => sub { - unlink("$tmpdir/Preload/IncChange.pm") if -e "$tmpdir/Preload/IncChange.pm"; - - yath( - command => 'start', - args => ['-PPreload', '-r'], - pre => ["-D$tmpdir"], - exit => 0, - ); - - touch_files(); - - yath( - command => 'watch', - args => ['STOP'], - exit => 0, - test => sub { - my $out = shift; - - my $parsed = parse_output($out->{output}); - is( - $parsed, - { - 'default' => [ - 'Loaded Preload', - ], - 'A' => [ - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'Runner attempting to reload \'lib/Preload/A.pm\' in place...', - 'Loaded Preload::A', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'Runner attempting to reload \'lib/Preload/A.pm\' in place...', - 'Loaded Preload::A', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionA.pm\'...', - 'Runner attempting to reload \'lib/Preload/ExceptionA.pm\' in place...', - 'Loaded Preload::ExceptionA', - 'Runner failed to reload \'lib/Preload/ExceptionA.pm\' in place...', - 'Loaded Preload::ExceptionA again.', - 'BEGIN failed--compilation aborted at lib/Preload/ExceptionA.pm', - 'Compilation failed in require at lib/Test2/Harness/Runner/Reloader.pm', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningA.pm\'...', - 'Runner attempting to reload \'lib/Preload/WarningA.pm\' in place...', - 'Loaded Preload::WarningA', - 'Runner failed to reload \'lib/Preload/WarningA.pm\' in place...', - 'Loaded Preload::WarningA again.', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterA...', - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Churn 1', - 'FOO: foo 1', - 'Churn 2', - 'Churn 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/Churn.pm\'...', - 'Changed file \'Preload/Churn.pm\' contains churn sections, running them instead of a full reload...', - 'Churn 1', - 'FOO: foo 2', - 'Success reloading churn block (lib/Preload/Churn.pm lines 8 -> 16)', - 'Churn 2', - 'Success reloading churn block (lib/Preload/Churn.pm lines 18 -> 20)', - 'Error reloading churn block (lib/Preload/Churn.pm lines 22 -> 28): Died on count 3', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/nonperl1\'...', - 'Changed file \'lib/Preload/nonperl1\' has a reload callback, executing it instead of regular reloading...', - 'RELOAD CALLBACK nonperl1', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/nonperl2\'...', - 'Changed file \'lib/Preload/nonperl2\' has a reload callback, executing it instead of regular reloading...', - 'RELOAD CALLBACK nonperl2' - ], - 'B' => [ - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::ExporterA', - 'Loaded Preload::B', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'Runner attempting to reload \'lib/Preload/A.pm\' in place...', - 'Loaded Preload::A', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/B.pm\'...', - 'Runner attempting to reload \'lib/Preload/B.pm\' in place...', - 'Loaded Preload::B', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/A.pm\'...', - 'Runner attempting to reload \'lib/Preload/A.pm\' in place...', - 'Loaded Preload::A', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/B.pm\'...', - 'Runner attempting to reload \'lib/Preload/B.pm\' in place...', - 'Loaded Preload::B', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionA.pm\'...', - 'Runner attempting to reload \'lib/Preload/ExceptionA.pm\' in place...', - 'Loaded Preload::ExceptionA', - 'Runner failed to reload \'lib/Preload/ExceptionA.pm\' in place...', - 'Loaded Preload::ExceptionA again.', - 'BEGIN failed--compilation aborted at lib/Preload/ExceptionA.pm', - 'Compilation failed in require at lib/Test2/Harness/Runner/Reloader.pm', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExceptionB.pm\'...', - 'Runner attempting to reload \'lib/Preload/ExceptionB.pm\' in place...', - 'Loaded Preload::ExceptionB', - 'Runner failed to reload \'lib/Preload/ExceptionB.pm\' in place...', - 'Loaded Preload::ExceptionB again.', - 'BEGIN failed--compilation aborted at lib/Preload/ExceptionB.pm', - 'Compilation failed in require at lib/Test2/Harness/Runner/Reloader.pm', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningA.pm\'...', - 'Runner attempting to reload \'lib/Preload/WarningA.pm\' in place...', - 'Loaded Preload::WarningA', - 'Runner failed to reload \'lib/Preload/WarningA.pm\' in place...', - 'Loaded Preload::WarningA again.', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/WarningB.pm\'...', - 'Runner attempting to reload \'lib/Preload/WarningB.pm\' in place...', - 'Loaded Preload::WarningB', - 'Runner failed to reload \'lib/Preload/WarningB.pm\' in place...', - 'Loaded Preload::WarningB again.', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterA.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterA...', - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::B', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::ExporterB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/ExporterB.pm\'...', - 'blacklisting changed files and reloading stage...', - 'Blacklisting Preload::ExporterB...', - 'Loaded Preload::A', - 'Loaded Preload::WarningA', - 'Loaded Preload::ExceptionA', - 'Loaded Preload::B', - 'Loaded Preload::WarningB', - 'Loaded Preload::ExceptionB', - 'Loaded Preload::IncChange', - 'Runner detected a change in one or more preloaded modules...', - 'Runner detected changes in file \'lib/Preload/IncChange.pm\'...', - 'Runner attempting to reload \'lib/Preload/IncChange.pm\' in place...', - 'Runner failed to reload \'lib/Preload/IncChange.pm\' in place...', - 'Reloading \'Preload/IncChange.pm\' loaded \'TEMP/Preload/IncChange.pm\' instead of \'lib/Preload/IncChange.pm\', @INC must have been altered at lib/Test2/Harness/Runner/Reloader.pm' - ], - }, - "Reload happened as expected", - ); - }, - ); - - yath(command => 'stop', exit => 0); -}; - -done_testing; diff --git a/t/integration/reload/lib/Preload.pm b/t/integration/reload/lib/Preload.pm deleted file mode 100644 index c4e15f691..000000000 --- a/t/integration/reload/lib/Preload.pm +++ /dev/null @@ -1,54 +0,0 @@ -package Preload; -use strict; -use warnings; - -use Test2::Harness::Runner::Preload; - -print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - -my $path = __FILE__; -$path =~ s{\.pm$}{}; -use Data::Dumper; -print Dumper($path); - -stage A => sub { - default(); - - watch "$path/nonperl1" => sub { print "$$ $0 - RELOAD CALLBACK nonperl1\n" }; - - preload sub { - watch "$path/nonperl2" => sub { print "$$ $0 - RELOAD CALLBACK nonperl2\n" }; - }; - - preload 'Preload::A'; - preload 'Preload::WarningA'; - preload 'Preload::ExceptionA'; - preload 'Preload::ExporterA'; - preload 'Preload::Churn'; -}; - -stage B => sub { - reload_remove_check sub { - my %params = @_; - return 1 if $params{reload_file} eq $params{from_file}; - return 0; - }; - - preload sub { - *Preload::B::PreDefined = sub { 'yes' }; - }; - - preload 'Preload::A'; - preload 'Preload::WarningA'; - preload 'Preload::ExceptionA'; - preload 'Preload::ExporterA'; - - preload 'Preload::B'; - preload 'Preload::WarningB'; - preload 'Preload::ExceptionB'; - preload 'Preload::ExporterB'; - - preload 'Preload::IncChange'; -}; - -1; diff --git a/t/integration/reload/lib/Preload/A.pm b/t/integration/reload/lib/Preload/A.pm deleted file mode 100644 index 6a521aef0..000000000 --- a/t/integration/reload/lib/Preload/A.pm +++ /dev/null @@ -1,13 +0,0 @@ -package Preload::A; -use strict; -use warnings; - -BEGIN { - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::A //= 0; - $PRELOAD::A++; -} - -sub A { $PRELOAD::A } - -1; diff --git a/t/integration/reload/lib/Preload/B.pm b/t/integration/reload/lib/Preload/B.pm deleted file mode 100644 index 05b413ff6..000000000 --- a/t/integration/reload/lib/Preload/B.pm +++ /dev/null @@ -1,15 +0,0 @@ -package Preload::B; -use strict; -use warnings; - -BEGIN { - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::B //= 0; - $PRELOAD::B++; -} - -sub B { $PRELOAD::B } - -die "PreDefined sub is missing!" unless __PACKAGE__->can('PreDefined'); - -1; diff --git a/t/integration/reload/lib/Preload/Churn.pm b/t/integration/reload/lib/Preload/Churn.pm deleted file mode 100644 index f0c8ba53f..000000000 --- a/t/integration/reload/lib/Preload/Churn.pm +++ /dev/null @@ -1,30 +0,0 @@ -package Preload::Churn; - -our $counter; -$counter //= 0; -die "Counter incremented!" if $counter; -$counter++; - -# HARNESS-CHURN-START -our $counter2; -$counter2 //= 0; -print "$$ $0 - Churn 1\n"; -$counter2++; -my $foo = "foo $counter2"; -sub foo { $foo } -print "$$ $0 - FOO: " . Preload::Churn->foo . "\n"; -# HARNESS-CHURN-STOP - -# HARNESS-CHURN-START -print "$$ $0 - Churn 2\n"; -# HARNESS-CHURN-STOP - -# HARNESS-CHURN-START -our $counter3; -$counter3 //= 0; -die "$$ $0 - Died on count $counter3\n" if $counter3++; -print "$$ $0 - Churn 3\n"; -$counter3++; -# HARNESS-CHURN-STOP - -1; diff --git a/t/integration/reload/lib/Preload/ExceptionA.pm b/t/integration/reload/lib/Preload/ExceptionA.pm deleted file mode 100644 index 06a01c27b..000000000 --- a/t/integration/reload/lib/Preload/ExceptionA.pm +++ /dev/null @@ -1,14 +0,0 @@ -package Preload::ExceptionA; -use strict; -use warnings; - -BEGIN { - local $.; - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::ExA //= 0; - die "Loaded ${ \__PACKAGE__ } again.\n" if $PRELOAD::ExA++; -} - -sub ExA { $PRELOAD::ExA } - -1; diff --git a/t/integration/reload/lib/Preload/ExceptionB.pm b/t/integration/reload/lib/Preload/ExceptionB.pm deleted file mode 100644 index 89e47550c..000000000 --- a/t/integration/reload/lib/Preload/ExceptionB.pm +++ /dev/null @@ -1,15 +0,0 @@ -package Preload::ExceptionB; -use strict; -use warnings; - -BEGIN { - local $.; - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::ExB //= 0; - die "Loaded ${ \__PACKAGE__ } again.\n" if $PRELOAD::ExB++; -} - -sub ExB { $PRELOAD::ExB } - -1; - diff --git a/t/integration/reload/lib/Preload/ExporterA.pm b/t/integration/reload/lib/Preload/ExporterA.pm deleted file mode 100644 index 8f72db781..000000000 --- a/t/integration/reload/lib/Preload/ExporterA.pm +++ /dev/null @@ -1,16 +0,0 @@ -package Preload::ExporterA; -use strict; -use warnings; - -BEGIN { - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::EA //= 0; - $PRELOAD::EA++; -} - -use parent 'Exporter'; -our @EXPORT_OK = 'EA'; - -sub EA { $PRELOAD::EA } - -1; diff --git a/t/integration/reload/lib/Preload/ExporterB.pm b/t/integration/reload/lib/Preload/ExporterB.pm deleted file mode 100644 index 6580a275d..000000000 --- a/t/integration/reload/lib/Preload/ExporterB.pm +++ /dev/null @@ -1,18 +0,0 @@ -package Preload::ExporterB; -use strict; -use warnings; - -BEGIN { - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::EB //= 0; - $PRELOAD::EB++; -} - -our @EXPORT_OK = ('EB'); - -sub import { 1 } - -sub EB { $PRELOAD::EB } - -1; - diff --git a/t/integration/reload/lib/Preload/IncChange.pm b/t/integration/reload/lib/Preload/IncChange.pm deleted file mode 100644 index 72064d1c5..000000000 --- a/t/integration/reload/lib/Preload/IncChange.pm +++ /dev/null @@ -1,9 +0,0 @@ -package Preload::IncChange; -use strict; -use warnings; - -BEGIN { - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; -} - -1; diff --git a/t/integration/reload/lib/Preload/WarningA.pm b/t/integration/reload/lib/Preload/WarningA.pm deleted file mode 100644 index c62513e6d..000000000 --- a/t/integration/reload/lib/Preload/WarningA.pm +++ /dev/null @@ -1,14 +0,0 @@ -package Preload::WarningA; -use strict; -use warnings; - -BEGIN { - local $.; - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::WA //= 0; - warn "Loaded ${ \__PACKAGE__ } again.\n" if $PRELOAD::WA++; -} - -sub WA { $PRELOAD::WA } - -1; diff --git a/t/integration/reload/lib/Preload/WarningB.pm b/t/integration/reload/lib/Preload/WarningB.pm deleted file mode 100644 index 45a942a92..000000000 --- a/t/integration/reload/lib/Preload/WarningB.pm +++ /dev/null @@ -1,14 +0,0 @@ -package Preload::WarningB; -use strict; -use warnings; - -BEGIN { - local $.; - print "$$ $0 - Loaded ${ \__PACKAGE__ }\n"; - $PRELOAD::WB //= 0; - warn "Loaded ${ \__PACKAGE__ } again.\n" if $PRELOAD::WB++; -} - -sub WB { $PRELOAD::WB } - -1; diff --git a/t/integration/reload/lib/Preload/nonperl1 b/t/integration/reload/lib/Preload/nonperl1 deleted file mode 100644 index 0afc6045c..000000000 --- a/t/integration/reload/lib/Preload/nonperl1 +++ /dev/null @@ -1 +0,0 @@ -1; diff --git a/t/integration/reload/lib/Preload/nonperl2 b/t/integration/reload/lib/Preload/nonperl2 deleted file mode 100644 index 765da1143..000000000 --- a/t/integration/reload/lib/Preload/nonperl2 +++ /dev/null @@ -1 +0,0 @@ -2; diff --git a/t/integration/reload_syntax_error.t b/t/integration/reload_syntax_error.t deleted file mode 100644 index 262cb0f86..000000000 --- a/t/integration/reload_syntax_error.t +++ /dev/null @@ -1,100 +0,0 @@ -use Test2::V0; -use Test2::Require::AuthorTesting; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; -use Test2::Harness::Util qw/clean_path/; - -use Test2::Harness::Util::JSON qw/decode_json/; - -use Test2::Util qw/CAN_REALLY_FORK/; -skip_all "Cannot fork, skipping preload test" - if $ENV{T2_NO_FORK} || !CAN_REALLY_FORK; - -my $tx = __FILE__ . 'x'; - -my $tmpdir = tempdir(CLEANUP => 1); -mkdir("$tmpdir/Preload") or die "($tmpdir/Preload) $!"; - -{ - open(my $fh, '>', "$tmpdir/Preload.pm") or die "Could not create preload: $!"; - print $fh <<' EOT'; -package Preload; -use strict; -use warnings; - -use Test2::Harness::Runner::Preload; - -stage A => sub { - default(); - - # Do like this to avoid blacklisting - preload sub { require Preload::Flux }; -}; - -1; - EOT -} - -sub touch { - my ($inject) = @_; - my $path = "$tmpdir/Preload/Flux.pm"; - note "Touching $path..."; - sleep 2; - - open(my $fh, '>', $path) or die $!; - - print $fh <<" EOT"; -package Preload::Flux; -use strict; -use warnings; - -sub foo { 'foo' } - -$inject - -1; - EOT - - close($fh); -} - -touch('$Preload::Flux::VAR = "initial";'); - -yath( - command => 'start', - pre => ["-D$tmpdir"], - args => ["-I$tmpdir", '-PPreload'], - debug => 2, - exit => 0, -); - -yath( - command => 'run', - args => [$tx, '::', 'initial'], - exit => 0, -); - -touch('$Preload::Flux::VAR = "Syntax Error $bob";'); - -yath( - command => 'run', - args => [$tx], # no arg, so undef - exit => 0, -); - -touch('$Preload::Flux::VAR = "fixed";'); - -yath( - command => 'run', - args => [$tx, '::', 'fixed'], - exit => 0, -); - - -yath(command => 'stop', exit => 0); - -done_testing; diff --git a/t/integration/reload_syntax_error.tx b/t/integration/reload_syntax_error.tx deleted file mode 100644 index 3a54fe890..000000000 --- a/t/integration/reload_syntax_error.tx +++ /dev/null @@ -1,4 +0,0 @@ -use Test2::V0; -my ($want) = @ARGV; -is($Preload::Flux::VAR, $want, "Var set as expected"); -done_testing; diff --git a/t/integration/replay.t b/t/integration/replay.t deleted file mode 100644 index 803620bd1..000000000 --- a/t/integration/replay.t +++ /dev/null @@ -1,60 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -sub clean_output { - my $out = shift; - - $out->{output} =~ s/^.*duration.*$//m; - $out->{output} =~ s/^.*Wrote log file:.*$//m; - $out->{output} =~ s/^.*Symlinked to:.*$//m; - $out->{output} =~ s/^\s*Wall Time:.*seconds//m; - $out->{output} =~ s/^\s*CPU Time:.*s\)//m; - $out->{output} =~ s/^\s*CPU Usage:.*%//m; - $out->{output} =~ s/^\s*-+$//m; - $out->{output} =~ s/^\s+$//m; - $out->{output} =~ s/\n+/\n/g; - $out->{output} =~ s/^\s+//mg; -} - -my $out1 = yath( - command => 'test', - args => [$dir, '--ext=tx'], - log => 1, - exit => T(), - test => sub { - my $out = shift; - clean_output($out); - - like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the log"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the log"); - - }, -); - -my $logfile = $out1->{log}->name; - -yath( - command => 'replay', - args => [$logfile], - exit => $out1->{exit}, - test => sub { - my $out2 = shift; - clean_output($out2); - clean_output($out1); - - is($out2->{output}, $out1->{output}, "Replay has identical output to original"); - }, -); - -done_testing; diff --git a/t/integration/replay/fail.tx b/t/integration/replay/fail.tx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/replay/fail.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/replay/pass.tx b/t/integration/replay/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/replay/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/resource.t b/t/integration/resource.t deleted file mode 100644 index cc1faab24..000000000 --- a/t/integration/resource.t +++ /dev/null @@ -1,102 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-j4', "-D$dir", '-R+Resource'], - log => 1, - exit => 0, - test => sub { - my $out = shift; - my $log = $out->{log}; - - my @events = $log->poll(); - - my %pids; - my %msgs; - for my $event (@events) { - my $f = $event->{facet_data}; - my $info = $f->{info} or next; - for my $i (@$info) { - next unless $i->{tag} eq 'INTERNAL'; - if ($i->{details} =~ m/^(\S+) - (yath-\S+)$/) { - $pids{$1} = $2; - next; - } - - next unless $i->{details} =~ m/^(\S+) - (?:(\S+): \S+ - (\d)|(.+))$/; - my ($pid, $action, $res_id) = ($1, ($2 || $4), $3); - - $pid = $pids{$pid} // $pid; - - if ($res_id) { - push @{$msgs{$pid}->{$res_id}} => $action; - } - else { - push @{$msgs{$pid}->{$_}} => $action for keys %{$msgs{$pid}}; - } - } - } - - is( - $msgs{"yath-nested-runner"}, - { - 1 => [ - 'Record', - 'Release', - 'Record', - 'Release', - 'RESOURCE CLEANUP', - ], - 2 => [ - 'Record', - 'Release', - 'Record', - 'Release', - 'RESOURCE CLEANUP', - ], - }, - "The nested runner saw the records and releases, and then cleaned up at the end." - ); - - is( - $msgs{'yath-nested-scheduler'}, - { - 1 => [ - 'Assigned', - 'Record', - 'No Slots', - 'Release', - 'Assigned', - 'Record', - 'Release', - ], - 2 => [ - 'Assigned', - 'Record', - 'No Slots', - 'Release', - 'Assigned', - 'Record', - 'Release', - ], - }, - "The scheduler handled assigning slots, knew when it was out, then knew when more were ready", - ); - }, -); - -done_testing; - -1; diff --git a/t/integration/resource/Resource.pm b/t/integration/resource/Resource.pm deleted file mode 100644 index ce9cee2f2..000000000 --- a/t/integration/resource/Resource.pm +++ /dev/null @@ -1,78 +0,0 @@ -package Resource; -use strict; -use warnings; - -use parent 'Test2::Harness::Runner::Resource'; - -my $limit = 2; - -my $no_slots_msg = 0; -sub available { - my $self = shift; - my ($task) = @_; - - for my $slot (1 .. $limit) { - return 1 unless defined $self->{$slot}; - } - - $self->message("No Slots") unless $no_slots_msg++; - return 0; -} - -sub assign { - my $self = shift; - my ($task, $state) = @_; - - for my $slot (1 .. $limit) { - next if defined $self->{$slot}; - - $self->message("Assigned: $task->{job_id} - $slot"); - $state->{record} = $slot; - $state->{env_vars}->{RESOURCE_TEST} = $slot; - push @{$state->{args}} => $slot; - - return; - } - - die "Error, no slots to assign"; -} - -sub record { - my $self = shift; - my ($job_id, $slot) = @_; - - $self->message("Record: $job_id - $slot"); - $self->{$slot} = $job_id; - $self->{$job_id} = $slot; -} - -sub release { - my $self = shift; - my ($job_id) = @_; - - my $slot = delete $self->{$job_id}; - delete $self->{$slot}; - $self->message("Release: $job_id - $slot"); -} - -sub cleanup { - my $self = shift; - - $self->message("RESOURCE CLEANUP"); -} - -my $pid; -sub message { - my $self = shift; - my ($msg) = @_; - - if (!$pid || $$ != $pid) { - $pid = $$; - - print "$$ - $0\n"; - } - - print "$$ - $msg\n"; -} - -1; diff --git a/t/integration/resource/a.tx b/t/integration/resource/a.tx deleted file mode 100644 index 63e08ee3c..000000000 --- a/t/integration/resource/a.tx +++ /dev/null @@ -1,8 +0,0 @@ -use Test2::V0; - -ok($ENV{RESOURCE_TEST}, "Set the env var"); -is($ARGV[0], $ENV{RESOURCE_TEST}, "Set the test cli argument to the same value"); - -sleep 1; - -done_testing; diff --git a/t/integration/resource/b.tx b/t/integration/resource/b.tx deleted file mode 100644 index 63e08ee3c..000000000 --- a/t/integration/resource/b.tx +++ /dev/null @@ -1,8 +0,0 @@ -use Test2::V0; - -ok($ENV{RESOURCE_TEST}, "Set the env var"); -is($ARGV[0], $ENV{RESOURCE_TEST}, "Set the test cli argument to the same value"); - -sleep 1; - -done_testing; diff --git a/t/integration/resource/c.tx b/t/integration/resource/c.tx deleted file mode 100644 index 63e08ee3c..000000000 --- a/t/integration/resource/c.tx +++ /dev/null @@ -1,8 +0,0 @@ -use Test2::V0; - -ok($ENV{RESOURCE_TEST}, "Set the env var"); -is($ARGV[0], $ENV{RESOURCE_TEST}, "Set the test cli argument to the same value"); - -sleep 1; - -done_testing; diff --git a/t/integration/resource/d.tx b/t/integration/resource/d.tx deleted file mode 100644 index 63e08ee3c..000000000 --- a/t/integration/resource/d.tx +++ /dev/null @@ -1,8 +0,0 @@ -use Test2::V0; - -ok($ENV{RESOURCE_TEST}, "Set the env var"); -is($ARGV[0], $ENV{RESOURCE_TEST}, "Set the test cli argument to the same value"); - -sleep 1; - -done_testing; diff --git a/t/integration/retry-symlinks/retry.tx b/t/integration/retry-symlinks/retry.tx deleted file mode 100644 index 38d50061f..000000000 --- a/t/integration/retry-symlinks/retry.tx +++ /dev/null @@ -1,30 +0,0 @@ -# HARNESS-DURATION-SHORT -use strict; -use warnings; - -use Test2::V0; -use Test2::API qw/test2_formatter/; - -ok(1, "Minimal result"); - -sub { - my $ctx = context(); - - diag "Formatter: " . test2_formatter(); - - $ctx->release; -}->(); - - -$ENV{T2_HARNESS_JOB_IS_TRY} //= 0; -$ENV{FAIL_ONCE} //= 0; -$ENV{FAIL_ALWAYS} //= 0; - -diag "JOB_IS_TRY = $ENV{T2_HARNESS_JOB_IS_TRY}"; -diag "FAIL_ONCE = $ENV{FAIL_ONCE}"; -diag "FAIL_ALWAYS = $ENV{FAIL_ALWAYS}"; - -ok(0, "Should fail once") if $ENV{FAIL_ONCE} && $ENV{T2_HARNESS_JOB_IS_TRY} < 1; -ok(0, "Should fail always") if $ENV{FAIL_ALWAYS}; - -done_testing(); diff --git a/t/integration/retry-symlinks/symlink.tl b/t/integration/retry-symlinks/symlink.tl deleted file mode 120000 index 7052a12d5..000000000 --- a/t/integration/retry-symlinks/symlink.tl +++ /dev/null @@ -1 +0,0 @@ -retry.tx \ No newline at end of file diff --git a/t/integration/retry-timeout/retry.tx b/t/integration/retry-timeout/retry.tx deleted file mode 100644 index b31e5c83d..000000000 --- a/t/integration/retry-timeout/retry.tx +++ /dev/null @@ -1,24 +0,0 @@ -# HARNESS-TIMEOUT-EVENT 5 -use strict; -use warnings; - -use Test2::V0; -use Test2::API qw/test2_formatter/; - -pass("Test Start"); - -$ENV{T2_HARNESS_JOB_IS_TRY} //= 0; -$ENV{FAIL_ONCE} //= 0; -$ENV{FAIL_ALWAYS} //= 0; - -diag "JOB_IS_TRY = $ENV{T2_HARNESS_JOB_IS_TRY}"; -diag "FAIL_ONCE = $ENV{FAIL_ONCE}"; -diag "FAIL_ALWAYS = $ENV{FAIL_ALWAYS}"; - -if ( $ENV{FAIL_ONCE} && $ENV{T2_HARNESS_JOB_IS_TRY} < 1 ) { - sleep 1 while 1; -} - -pass("Final Test"); - -done_testing(); diff --git a/t/integration/retry.t b/t/integration/retry.t deleted file mode 100644 index afc67d7b3..000000000 --- a/t/integration/retry.t +++ /dev/null @@ -1,139 +0,0 @@ -use Test2::V0; -# HARNESS-DURATION-LONG - -use App::Yath::Tester qw/yath/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -run_tests('test'); - -my $project = "asgadfgds"; - -unless ($ENV{AUTOMATED_TESTING}) { - my $out = yath( - command => 'start', - pre => ['--project', $project], - args => [], - exit => 0, - test => sub { - run_tests('run'); - yath(command => 'stop', args => [], exit => 0); - } - ); -} - -sub run_tests { - my ($cmd) = @_; - - yath( - command => $cmd, - pre => ['--project', $project], - args => [$dir, '--ext=tx', '-r3'], - log => 1, - exit => 0, - test => sub { - my $out = shift; - my $final = ($out->{log}->poll())[-2]; - is($final->{facet_data}->{harness_final}->{pass}, T(), "Passed in log"); - }, - ); - - yath( - command => $cmd, - pre => ['--project', $project], - args => [$dir, '--ext=tx', '-r3', '--env-var' => "FAIL_ONCE=1", '-v'], - log => 1, - exit => 0, - debug => 0, - test => sub { - my $out = shift; - - my $final = ($out->{log}->poll())[-2]; - my $retry_data = $final->{facet_data}->{harness_final}->{retried}->[0]; - ok($retry_data, "got retry data") or return; - my ($uuid, $tries, $file, $status) = @$retry_data; - is($tries, 2, "Tried twice"); - like($file, qr{retry\.tx}, "Retried the right file"); - is($status, 'YES', "Eventually passed"); - }, - ); - - yath( - command => $cmd, - pre => ['--project', $project], - args => [$dir, '--ext=tx', '-r3', '--env-var' => "FAIL_ALWAYS=1"], - log => 1, - exit => T(), - test => sub { - my $out = shift; - my $final = ($out->{log}->poll())[-2]; - my $retry_data = $final->{facet_data}->{harness_final}->{retried}->[0]; - my ($uuid, $tries, $file, $status) = @$retry_data; - - is($tries, 4, "Tried 4 times: 1 run + 3 retries"); - like($file, qr{retry\.tx}, "Retried the right file"); - is($status, 'NO', "Never passed"); - }, - ); - - { - note q[Retrying a symlink]; - - my $sdir = $dir . '-symlinks'; - my $symlink = "$sdir/symlink.tl"; - - unlink $symlink if -e $symlink; - if ( eval{ symlink('retry.tx', $symlink) } ) { - yath( - command => 'test', - args => [$sdir, '--ext=tl', '--retry' => 1, '--env-var' => "FAIL_ONCE=1", '-v' ], - log => 1, - exit => 0, - test => sub { - my $out = shift; - - my $final = ($out->{log}->poll())[-2]; - my $retry_data = $final->{facet_data}->{harness_final}->{retried}->[0]; - my ($uuid, $tries, $file, $status) = @$retry_data; - - is $tries, 2, 'retried a broken symlink'; - is $file, 't/integration/retry-symlinks/symlink.tl', "using symlink name"; - is $status, 'YES', 'Succeeded Eventually: YES'; - - unlike($out->{output}, qr{FAILED}, q[no failures]); - }, - ); - } - } - - { - note q[Retrying a test failing due to a timeout]; - - my $sdir = $dir . '-timeout'; - yath( - command => 'test', - args => [$sdir, '--ext=tx', '--retry' => 1, '--env-var' => "FAIL_ONCE=1", '-v' ], - log => 1, - exit => 0, - test => sub { - my $out = shift; - - my $final = ($out->{log}->poll())[-2]; - my $retry_data = $final->{facet_data}->{harness_final}->{retried}->[0]; - my ($uuid, $tries, $file, $status) = @$retry_data; - - #note $out->{output}; - - is $tries, 2, 'retried a test when failing due to a timeout'; - is $file, 't/integration/retry-timeout/retry.tx', "retry.txt test"; - is $status, 'YES', 'Succeeded Eventually: YES'; - - unlike($out->{output}, qr{FAILED}, q[no failures]); - }, - ); - } -}; - -done_testing; diff --git a/t/integration/retry/retry.tx b/t/integration/retry/retry.tx deleted file mode 100644 index 38d50061f..000000000 --- a/t/integration/retry/retry.tx +++ /dev/null @@ -1,30 +0,0 @@ -# HARNESS-DURATION-SHORT -use strict; -use warnings; - -use Test2::V0; -use Test2::API qw/test2_formatter/; - -ok(1, "Minimal result"); - -sub { - my $ctx = context(); - - diag "Formatter: " . test2_formatter(); - - $ctx->release; -}->(); - - -$ENV{T2_HARNESS_JOB_IS_TRY} //= 0; -$ENV{FAIL_ONCE} //= 0; -$ENV{FAIL_ALWAYS} //= 0; - -diag "JOB_IS_TRY = $ENV{T2_HARNESS_JOB_IS_TRY}"; -diag "FAIL_ONCE = $ENV{FAIL_ONCE}"; -diag "FAIL_ALWAYS = $ENV{FAIL_ALWAYS}"; - -ok(0, "Should fail once") if $ENV{FAIL_ONCE} && $ENV{T2_HARNESS_JOB_IS_TRY} < 1; -ok(0, "Should fail always") if $ENV{FAIL_ALWAYS}; - -done_testing(); diff --git a/t/integration/signals.t b/t/integration/signals.t deleted file mode 100644 index a9770b28d..000000000 --- a/t/integration/signals.t +++ /dev/null @@ -1,26 +0,0 @@ -use Test2::V0; -use Test2::Require::AuthorTesting; - -use File::Temp qw/tempdir/; -use File::Spec; - -use Test2::Harness::Util::File::JSONL; -use App::Yath::Tester qw/yath/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -for ( 1..10 ) { - # the tests are flapping when using something like '%INC = %INC'.... - # make sure the issue is fixed by running them a few times - my $out = yath( - prefix => "Try $_: ", - command => 'test', - args => [$dir], - log => 0, - exit => 0, - ); -} - -done_testing; diff --git a/t/integration/signals/abrt_or_iot.t b/t/integration/signals/abrt_or_iot.t deleted file mode 100644 index 434f83af6..000000000 --- a/t/integration/signals/abrt_or_iot.t +++ /dev/null @@ -1,17 +0,0 @@ -#!perl - -use strict; -use warnings; -use Test::More; - -# note: this is going to fail if IOT is defined before... -# %SIG = %SIG; will introduce a flapping behavior - -$SIG{'ABRT'} = sub { - my ($sig) = @_; - is $sig, 'ABRT'; -}; - -kill 'ABRT', $$; - -done_testing; diff --git a/t/integration/slots_per_job.t b/t/integration/slots_per_job.t deleted file mode 100644 index 01f4679b6..000000000 --- a/t/integration/slots_per_job.t +++ /dev/null @@ -1,9 +0,0 @@ -use Test2::V0; - -skip_all "This test only works under Test2::Harness" unless $ENV{TEST2_HARNESS_ACTIVE}; - -ok(!$ENV{T2_HARNESS_JOB_CONCURRENCY}, "T2_HARNESS_JOB_CONCURRENCY is not set"); -ok($ENV{T2_HARNESS_MY_JOB_CONCURRENCY}, "Have job concurrency set ($ENV{T2_HARNESS_MY_JOB_CONCURRENCY})"); -ok($ENV{T2_HARNESS_MY_JOB_CONCURRENCY} >= 1, "Have job concurrency set to a positive number ($ENV{T2_HARNESS_MY_JOB_CONCURRENCY})"); - -done_testing; diff --git a/t/integration/slots_per_job2.t b/t/integration/slots_per_job2.t deleted file mode 100644 index 37ad69ade..000000000 --- a/t/integration/slots_per_job2.t +++ /dev/null @@ -1,11 +0,0 @@ -use Test2::V0; -use List::Util qw/min/; -# HARNESS-JOB-SLOTS 1 3 - -skip_all "This test only works under Test2::Harness" unless $ENV{TEST2_HARNESS_ACTIVE}; - -ok(!$ENV{T2_HARNESS_JOB_CONCURRENCY}, "T2_HARNESS_JOB_CONCURRENCY is not set"); -ok($ENV{T2_HARNESS_MY_JOB_CONCURRENCY}, "Have job concurrency set ($ENV{T2_HARNESS_MY_JOB_CONCURRENCY})"); -is($ENV{T2_HARNESS_MY_JOB_CONCURRENCY}, in_set(1, 2, 3), "Have job concurrency set ($ENV{T2_HARNESS_MY_JOB_CONCURRENCY})"); - -done_testing; diff --git a/t/integration/slots_per_job3.t b/t/integration/slots_per_job3.t deleted file mode 100644 index 9b20812af..000000000 --- a/t/integration/slots_per_job3.t +++ /dev/null @@ -1,10 +0,0 @@ -use Test2::V0; -# HARNESS-JOB-SLOTS 2 - -skip_all "This test only works under Test2::Harness" unless $ENV{TEST2_HARNESS_ACTIVE}; - -ok(!$ENV{T2_HARNESS_JOB_CONCURRENCY}, "T2_HARNESS_JOB_CONCURRENCY is not set"); -ok($ENV{T2_HARNESS_MY_JOB_CONCURRENCY}, "Have job concurrency set ($ENV{T2_HARNESS_MY_JOB_CONCURRENCY})"); -is($ENV{T2_HARNESS_MY_JOB_CONCURRENCY}, 2, "Have job concurrency set (2)"); - -done_testing; diff --git a/t/integration/smoke.t b/t/integration/smoke.t deleted file mode 100644 index a411218d1..000000000 --- a/t/integration/smoke.t +++ /dev/null @@ -1,83 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - pre => ['-p+SmokePlugin'], - args => [$dir, '--ext=tx'], - log => 1, - exit => 0, - test => \&the_test, -); - -yath( - command => 'test', - pre => ['-p+SmokePlugin'], - args => [$dir, '-j3', '--ext=tx'], - log => 1, - exit => 0, - test => \&the_test, -); - -sub the_test { - my $out = shift; - my $log = $out->{log}; - - my @order; - my @events = $log->poll(); - while (@events) { - if (my $event = shift @events) { - my $f = $event->{facet_data}; - - if (my $l = $f->{harness_job_start}) { - push @order => $l; - } - } - - # Check for additional events, probably should not have any, but we may hit - # a buffering limit in the log reader and need additional polls. - push @events => $log->poll; - } - - # We care about the order in which events happened based on time stamp, not the - # order in which they were collected, which may be different. Here we will sort - # based on stamp. - @order = sort { $a->{stamp} <=> $b->{stamp} } @order; - - is( - [map { $_->{rel_file} } @order[0 .. 3]], - bag { - item match qr/a\.tx$/; - item match qr/c\.tx$/; - item match qr/e\.tx$/; - item match qr/g\.tx$/; - end; - }, - "The 4 smoke tests ran first" - ); - - is( - [map { $_->{rel_file} } @order[4 .. 7]], - bag { - item match qr/b\.tx$/; - item match qr/d\.tx$/; - item match qr/f\.tx$/; - item match qr/h\.tx$/; - end; - }, - "The 4 non-smoke tests ran later" - ); -} - -done_testing; diff --git a/t/integration/smoke/a.tx b/t/integration/smoke/a.tx deleted file mode 100644 index 84bb1b356..000000000 --- a/t/integration/smoke/a.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; diff --git a/t/integration/smoke/b.tx b/t/integration/smoke/b.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/b.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/c.tx b/t/integration/smoke/c.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/c.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/d.tx b/t/integration/smoke/d.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/d.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/e.tx b/t/integration/smoke/e.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/e.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/f.tx b/t/integration/smoke/f.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/f.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/g.tx b/t/integration/smoke/g.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/g.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/h.tx b/t/integration/smoke/h.tx deleted file mode 100644 index f0d08841a..000000000 --- a/t/integration/smoke/h.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -ok(1, "pass"); - -done_testing; - diff --git a/t/integration/smoke/lib/SmokePlugin.pm b/t/integration/smoke/lib/SmokePlugin.pm deleted file mode 100644 index 9dc3eb4a2..000000000 --- a/t/integration/smoke/lib/SmokePlugin.pm +++ /dev/null @@ -1,17 +0,0 @@ -package SmokePlugin; -use strict; -use warnings; - -use parent 'App::Yath::Plugin'; - -sub munge_files { - my $self = shift; - my ($tests, $settings) = @_; - - for my $test (@$tests) { - next unless $test->relative =~ m/[aceg]\.tx$/; - $test->set_smoke; - } -} - -1; diff --git a/t/integration/speedtag.t b/t/integration/speedtag.t deleted file mode 100644 index 947c20ca7..000000000 --- a/t/integration/speedtag.t +++ /dev/null @@ -1,52 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; -use File::Copy qw/copy/; - -use Test2::Harness::Util::File::JSONL; - -use App::Yath::Tester qw/yath/; - -use App::Yath::Util qw/find_yath/; -find_yath(); # cache result before we chdir - -my $tmp = tempdir(CLEANUP => 1); - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my $pass = File::Spec->catfile($tmp, 'pass.tx'); -my $pass2 = File::Spec->catfile($tmp, 'pass2.tx'); - -copy(File::Spec->catfile($dir, 'pass.tx'), $pass); -copy(File::Spec->catfile($dir, 'pass2.tx'), $pass2); - -my $out = yath(command => 'test', args => [$tmp, '--ext=tx'], log => 1, exit => 0); -my $log = $out->{log}->name; - -yath( - command => 'speedtag', - args => [$log], - exit => 0, - test => sub { - like($_, qr/Tagged .*pass\.tx/, "Indicate we tagged pass"); - like($_, qr/Tagged .*pass2\.tx/, "Indicate we tagged pass2"); - - for my $file ($pass, $pass2) { - open(my $fh, '<', $file) or die $!; - my $found = 0; - while (my $line = <$fh>) { - chomp($line); - next unless $line =~ m/^#\s*HARNESS-DURATION-(SHORT|MEDIUM|LONG)$/; - $found = 1; - last; - } - $file =~ s/^.*(pass\d?\.tx)$/$1/; - ok($found, "Tagged file $file"); - } - }, -); - -done_testing; diff --git a/t/integration/speedtag/pass.tx b/t/integration/speedtag/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/speedtag/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/speedtag/pass2.tx b/t/integration/speedtag/pass2.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/speedtag/pass2.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/stamps.t b/t/integration/stamps.t deleted file mode 100644 index cb4c8a7bc..000000000 --- a/t/integration/stamps.t +++ /dev/null @@ -1,32 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-A', '--no-plugins', '-pTestPlugin', '-v'], - exit => T(), - log => 1, - test => sub { - my $out = shift; - - while (my @events = $out->{log}->poll()) { - for my $event (@events) { - last unless $event; - ok($event->{stamp}, "Event had a timestamp"); - } - } - }, -); - -done_testing; diff --git a/t/integration/stamps/fail.tx b/t/integration/stamps/fail.tx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/stamps/fail.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/stamps/lib/App/Yath/Plugin/TestPlugin.pm b/t/integration/stamps/lib/App/Yath/Plugin/TestPlugin.pm deleted file mode 100644 index a63912de2..000000000 --- a/t/integration/stamps/lib/App/Yath/Plugin/TestPlugin.pm +++ /dev/null @@ -1,16 +0,0 @@ -package App::Yath::Plugin::TestPlugin; -use strict; -use warnings; - -use Test2::Harness::Util::JSON qw/encode_json/; - -use parent 'App::Yath::Plugin'; - -sub handle_event { - my $self = shift; - my ($event) = @_; - - die "Event did not have a stamp!" unless $event->stamp; -} - -1; diff --git a/t/integration/stamps/pass.tx b/t/integration/stamps/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/stamps/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/tapsubtest.t b/t/integration/tapsubtest.t deleted file mode 100644 index b6f683540..000000000 --- a/t/integration/tapsubtest.t +++ /dev/null @@ -1,29 +0,0 @@ -use Test2::V0; - -use App::Yath::Tester qw/yath/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '-v'], - exit => 0, - test => sub { - my $todo = todo "FIXME #216"; - my $out = shift; - - chomp(my $want = <<' EOT'); -[ PASS ] job 1 +~buffered -[ PASS ] job 1 + buffered ok -[ PLAN ] job 1 | Expected assertions: 1 - job 1 ^ -[ PLAN ] job 1 Expected assertions: 1 - EOT - - like($out->{output}, qr{\Q$want\E}, "Got the desired output"); - }, -); - -done_testing; diff --git a/t/integration/tapsubtest/test.tx b/t/integration/tapsubtest/test.tx deleted file mode 100644 index 89dfb5c0b..000000000 --- a/t/integration/tapsubtest/test.tx +++ /dev/null @@ -1,9 +0,0 @@ -# HARNESS-NO-STREAM -use Test2::V0; -use Test2::Tools::Subtest qw/subtest_buffered/; - -subtest_buffered buffered => sub { - ok(1, "buffered ok"); -}; - -done_testing; diff --git a/t/integration/test-broken-symlinks/keepme b/t/integration/test-broken-symlinks/keepme deleted file mode 100644 index d00491fd7..000000000 --- a/t/integration/test-broken-symlinks/keepme +++ /dev/null @@ -1 +0,0 @@ -1 diff --git a/t/integration/test-broken-symlinks/pass.tx b/t/integration/test-broken-symlinks/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/test-broken-symlinks/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/test-durations.json b/t/integration/test-durations.json deleted file mode 100644 index 49807e65c..000000000 --- a/t/integration/test-durations.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "t/integration/test-durations/fast-01.tx": "SHORT", - "t/integration/test-durations/fast-02.tx": "SHORT", - "t/integration/test-durations/fast-03.tx": "SHORT", - "t/integration/test-durations/fast-04.tx": "SHORT", - "t/integration/test-durations/slow-01.tx": "LONG", - "t/integration/test-durations/slow-02.tx": "LONG" -} \ No newline at end of file diff --git a/t/integration/test-durations/fast-01.tx b/t/integration/test-durations/fast-01.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/fast-01.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-durations/fast-02.tx b/t/integration/test-durations/fast-02.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/fast-02.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-durations/fast-03.tx b/t/integration/test-durations/fast-03.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/fast-03.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-durations/fast-04.tx b/t/integration/test-durations/fast-04.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/fast-04.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-durations/slow-01.tx b/t/integration/test-durations/slow-01.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/slow-01.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-durations/slow-02.tx b/t/integration/test-durations/slow-02.tx deleted file mode 100644 index 5199f1f2a..000000000 --- a/t/integration/test-durations/slow-02.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok 1, "$0"; - -done_testing; diff --git a/t/integration/test-inc/check-INC.tx b/t/integration/test-inc/check-INC.tx deleted file mode 100644 index e628b841b..000000000 --- a/t/integration/test-inc/check-INC.tx +++ /dev/null @@ -1,18 +0,0 @@ -package My::Simple::Test; - -use Test2::V0; - -my $has_dot_in_inc = grep { $_ eq '.' } @INC; -ok !$has_dot_in_inc, q['.' is not in @INC run with --no-unsafe-inc]; - -{ # relative path in @INC - my @relative_path = grep { index( $_, '/', 0 ) != 0 } @INC; - is \@relative_path, [], q[@INC does not contain relative path]; -} - -{ # check elative path in %INC - my @relative_path = grep { index( $_, '/', 0 ) != 0 } sort values %INC; - is \@relative_path, [], q[%INC does not contain relative path values]; -} - -done_testing; diff --git a/t/integration/test-symlinks/_base.xt b/t/integration/test-symlinks/_base.xt deleted file mode 100644 index 18efeace8..000000000 --- a/t/integration/test-symlinks/_base.xt +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -skip_all( "Do Not Run on the Main base.t" ) if $0 =~ m{\Q/_base.xt\E$}; - -like $0, qr{symlink_to_base\.xt}, q[symlink preserved in $0]; - -done_testing; diff --git a/t/integration/test-symlinks/symlink_to_base.xt b/t/integration/test-symlinks/symlink_to_base.xt deleted file mode 120000 index 2ccbf28d3..000000000 --- a/t/integration/test-symlinks/symlink_to_base.xt +++ /dev/null @@ -1 +0,0 @@ -_base.xt \ No newline at end of file diff --git a/t/integration/test.t b/t/integration/test.t deleted file mode 100644 index e9ec8cfd4..000000000 --- a/t/integration/test.t +++ /dev/null @@ -1,260 +0,0 @@ -use Test2::V0; - -use Config qw/%Config/; -use File::Temp qw/tempfile/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util qw/clean_path/; -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -yath( - command => 'test', - args => [$dir, '--ext=tx', '--ext=txx'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -yath( - command => 'test', - args => [$dir, '--ext=tx'], - exit => 0, - test => sub { - my $out = shift; - unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -yath( - command => 'test', - args => [$dir, '--ext=txx'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output"); - unlike($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -yath( - command => 'test', - args => [$dir, '-vvv'], - exit => T(), - test => sub { - my $out = shift; - - like($out->{output}, qr/No tests were seen!/, "Got error message"); - }, -); - - -note q[Checking --exclude-file option when a file is provided on the command line]; - -yath( - command => 'test', - args => [ "--exclude-file=$dir/fail.txx", "$dir/pass.tx", "$dir/fail.txx" ], - exit => 0, - test => sub { - my $out = shift; - - unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was excluded using '--exclude-file' option"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -note q[Checking --exclude-list option when a file is provided on the command line]; - -my ($fh, $list_name) = tempfile(UNLINK => 1); -print $fh "# GENERATED YATH TEST EXCLUSION LIST\n#$dir/pass.tx\n$dir/fail.txx"; -close($fh); - -yath( - command => 'test', - args => ["--exclude-list=$list_name", "$dir/pass.tx", "$dir/fail.txx"], - exit => 0, - test => sub { - my $out = shift; - - unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was excluded using '--exclude-list' option with a file"); - like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output"); - }, -); - -{ - note q[Testsuite using symlinks: check that $0 is preserved]; - - my $sdir = $dir . '-symlinks'; - my $base = "$sdir/_base.xt"; - my $symlink = "$sdir/symlink_to_base.xt"; - - unlink $symlink if -e $symlink; - if ( eval{ symlink('_base.xt', $symlink) } ) { - - yath( - command => 'test', - args => [$sdir, '--ext=xt' ], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{SKIPPED.*\Q$base\E}, "'_base.xt' was skipped"); - like($out->{output}, qr{PASSED.*\Q$symlink\E}, "'symlink_to_base.xt' passed [and is not skipped]"); - }, - ); - - yath( - command => 'test', - args => [ $base, $symlink ], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{SKIPPED.*\Q$base\E}, "'_base.xt' was skipped"); - like($out->{output}, qr{PASSED.*\Q$symlink\E}, "'symlink_to_base.xt' passed [and is not skipped]"); - }, - ); - - - } - -} - -{ - note q[Testsuite checking broken symlinks #103]; - - my $sdir = $dir . '-broken-symlinks'; - my $symlink = "$sdir/broken-symlink.tx"; - - unlink $symlink if -e $symlink; - if ( eval{ symlink('nothing-there', $symlink) } ) { - - yath( - command => 'test', - args => [$sdir, '--ext=tx' ], - exit => 0, - test => sub { - my $out = shift; - - unlike($out->{output}, qr{FAILED}, q[no failures]); - unlike($out->{output}, qr{\Qbroken-symlink.tx\E}, q[no mention of broken-symlink.tx] ); - like($out->{output}, qr{PASSED.*\Qt/integration/test-broken-symlinks/pass.tx\E}, q[t/integration/test-broken-symlinks/pass.tx PASSED]); - }, - ); - } -} - -{ - note "Testing durations when provided using a json file"; - - my $sdir = $dir . '-durations'; - - # using a directory - yath( - command => 'test', - args => [ '-v', '-j1', '--durations', "$sdir/../test-durations.json", '--ext=tx', $sdir, ], - exit => 0, - test => sub { - my $out = shift; - - my @lines = sort { - my ($aj) = ($a =~ m/job\s+(\d+)/) or return 0; - my ($bj) = ($b =~ m/job\s+(\d+)/) or return 0; - return $aj <=> $bj; - } grep { m/\Q( PASSED )\E/ } split /\n/, $out->{output}; - - is \@lines, array { - - item match qr{\Qslow-01.tx\E}; - item match qr{\Qslow-02.tx\E}; - item match qr{\Qfast-01.tx\E}; - item match qr{\Qfast-02.tx\E}; - item match qr{\Qfast-03.tx\E}; - item match qr{\Qfast-04.tx\E}; - - end; - }, "tests are run in order from slow to fast - using a directory"; - }, - ); - - # using a list of files - my @files = ( - "$sdir/fast-01.tx", "$sdir/fast-02.tx", "$sdir/fast-03.tx", "$sdir/fast-04.tx", - "$sdir/slow-01.tx", "$sdir/slow-02.tx" - ); - my %hfiles = map { $_ => 1 } @files; - yath( - command => 'test', - args => [ '-v', '-j1', '--durations', "$sdir/../test-durations.json", '--ext=tx', - keys %hfiles, # random order - ], - exit => 0, - test => sub { - my $out = shift; - - my @lines = sort { - my ($aj) = ($a =~ m/job\s+(\d+)/) or return 0; - my ($bj) = ($b =~ m/job\s+(\d+)/) or return 0; - return $aj <=> $bj; - } grep { m/\Q( PASSED )\E/ } split /\n/, $out->{output}; - - is \@lines, array { - - item match qr{\Qslow-01.tx\E}; - item match qr{\Qslow-02.tx\E}; - item match qr{\Qfast-01.tx\E}; - item match qr{\Qfast-02.tx\E}; - item match qr{\Qfast-03.tx\E}; - item match qr{\Qfast-04.tx\E}; - - end; - }, "tests are run in order from slow to fast - using a list of files"; - }, - ); -} - -if ("$]" >= 5.026) { - note q[Checking %INC and @INC setup]; - - local @INC = map { clean_path( $_ ) } grep { $_ ne '.' } @INC; - local $ENV{PERL5LIB} = join $Config{path_sep}, map { clean_path( $_ ) } grep { $_ ne '.' } split( $Config{path_sep}, $ENV{PERL5LIB} ); - local $ENV{PERL_USE_UNSAFE_INC}; - delete $ENV{PERL_USE_UNSAFE_INC}; - - my $sdir = $dir . '-inc'; - - yath( - command => 'test', - args => ['--ext=tx', '--no-unsafe-inc', $sdir], - exit => 0, - test => sub { - my $out = shift; - - unlike($out->{output}, qr{FAILED}, q[no failures]); - }, - ); -} - -yath( - command => 'test', - args => [$dir, '--ext=txxx', '::', 'foobar', 'baz' ], - exit => 0, - test => sub { - my $out = shift; - like($out->{output}, qr{PASSED}, 'Args after arisdottle are added to @ARGV'); - }, -); - -done_testing; diff --git a/t/integration/test/fail.txx b/t/integration/test/fail.txx deleted file mode 100644 index 43683a060..000000000 --- a/t/integration/test/fail.txx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(0, "Fail"); - -done_testing; diff --git a/t/integration/test/pass.tx b/t/integration/test/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/test/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/test/pass.txxx b/t/integration/test/pass.txxx deleted file mode 100644 index 2dc0c5f88..000000000 --- a/t/integration/test/pass.txxx +++ /dev/null @@ -1,7 +0,0 @@ -use Test2::V0; - -is (scalar @ARGV, 2); -is ( $ARGV[0], 'foobar'); -is ( $ARGV[1], 'baz'); - -done_testing(); diff --git a/t/integration/times.t b/t/integration/times.t deleted file mode 100644 index faf34c66c..000000000 --- a/t/integration/times.t +++ /dev/null @@ -1,36 +0,0 @@ -use Test2::V0; - -use File::Temp qw/tempdir/; -use File::Spec; - -use Test2::Harness::Util::File::JSONL; -use App::Yath::Tester qw/yath/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -my $out = yath( - command => 'test', - args => [$dir, '--ext=tx'], - log => 1, - exit => 0, -); - -my $log = $out->{log}->name; - -yath( - command => 'times', - args => [$log], - exit => 0, - test => sub { - my $out = shift; - - like($out->{output}, qr{Total .* Startup .* Events .* Cleanup .* File}m, "Got header"); - like($out->{output}, qr{t/integration/times/pass\.tx}m, "Got pass line"); - like($out->{output}, qr{t/integration/times/pass2\.tx}m, "Got pass2 line"); - like($out->{output}, qr{TOTAL}m, "Got total line"); - }, -); - -done_testing; diff --git a/t/integration/times/pass.tx b/t/integration/times/pass.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/times/pass.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/times/pass2.tx b/t/integration/times/pass2.tx deleted file mode 100644 index 091c40926..000000000 --- a/t/integration/times/pass2.tx +++ /dev/null @@ -1,5 +0,0 @@ -use Test2::V0; - -ok(1, "Pass"); - -done_testing; diff --git a/t/integration/verbose_env.t b/t/integration/verbose_env.t deleted file mode 100644 index 7a5796fee..000000000 --- a/t/integration/verbose_env.t +++ /dev/null @@ -1,39 +0,0 @@ -use Test2::V0; - -use Config qw/%Config/; -use File::Temp qw/tempfile/; -use File::Spec; - -use App::Yath::Tester qw/yath/; -use Test2::Harness::Util::File::JSONL; - -use Test2::Harness::Util qw/clean_path/; -use Test2::Harness::Util::JSON qw/decode_json/; - -my $dir = __FILE__; -$dir =~ s{\.t$}{}g; -$dir =~ s{^\./}{}; - -# Make it very wrong to start -local $ENV{T2_HARNESS_IS_VERBOSE} = 99; -local $ENV{HARNESS_IS_VERBOSE} = 99; - -yath( - command => 'test', - args => [File::Spec->catfile($dir, "not_verbose.tx")], - exit => F(), -); - -yath( - command => 'test', - args => ['-v', File::Spec->catfile($dir, "verbose1.tx")], - exit => F(), -); - -yath( - command => 'test', - args => ['-vv', File::Spec->catfile($dir, "verbose2.tx")], - exit => F(), -); - -done_testing; diff --git a/t/integration/verbose_env/not_verbose.tx b/t/integration/verbose_env/not_verbose.tx deleted file mode 100644 index a481ce9d2..000000000 --- a/t/integration/verbose_env/not_verbose.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -is($ENV{T2_HARNESS_IS_VERBOSE}, 0, "Not verbose"); -is($ENV{HARNESS_IS_VERBOSE}, 0, "Not verbose"); - -done_testing; diff --git a/t/integration/verbose_env/verbose1.tx b/t/integration/verbose_env/verbose1.tx deleted file mode 100644 index 411e01e9f..000000000 --- a/t/integration/verbose_env/verbose1.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -is($ENV{T2_HARNESS_IS_VERBOSE}, 1, "Verbosity level 1"); -is($ENV{HARNESS_IS_VERBOSE}, 1, "Verbosity level 1"); - -done_testing; diff --git a/t/integration/verbose_env/verbose2.tx b/t/integration/verbose_env/verbose2.tx deleted file mode 100644 index 8dc37ec74..000000000 --- a/t/integration/verbose_env/verbose2.tx +++ /dev/null @@ -1,6 +0,0 @@ -use Test2::V0; - -is($ENV{T2_HARNESS_IS_VERBOSE}, 2, "Verbosity level 2"); -is($ENV{HARNESS_IS_VERBOSE}, 2, "Verbosity level 2"); - -done_testing; diff --git a/t/lib/App/Yath/Command/broken.pm b/t/lib/App/Yath/Command/broken.pm deleted file mode 100644 index 5eaf55173..000000000 --- a/t/lib/App/Yath/Command/broken.pm +++ /dev/null @@ -1,3 +0,0 @@ -package App::Yath::Command::Broken; - -die "This command is broken!"; diff --git a/t/lib/App/Yath/Command/fake.pm b/t/lib/App/Yath/Command/fake.pm deleted file mode 100644 index 4440350f0..000000000 --- a/t/lib/App/Yath/Command/fake.pm +++ /dev/null @@ -1,15 +0,0 @@ -package App::Yath::Command::fake; -use strict; -use warnings; - -use parent 'App::Yath::Command'; - -use App::Yath::Options; - -option_group {prefix => 'fake'}, sub { - option($_, short => $_) for qw/x y z/; - - post sub { print "\n\nAAAA\n\n"; $main::POST_HOOK++ }; -}; - -1; diff --git a/t/lib/App/Yath/Plugin/Fail.pm b/t/lib/App/Yath/Plugin/Fail.pm deleted file mode 100644 index 0836657f9..000000000 --- a/t/lib/App/Yath/Plugin/Fail.pm +++ /dev/null @@ -1,26 +0,0 @@ -package App::Yath::Plugin::Test; -use strict; -use warnings; - -our $VERSION = '0.001016'; - -use parent 'App::Yath::Plugin'; - -my %CALLS; - -sub options { push @{$CALLS{options}} => [@_]; return } -sub pre_init { push @{$CALLS{pre_init}} => [@_]; return } -sub post_init { push @{$CALLS{post_init}} => [@_]; return } -sub find_files { push @{$CALLS{find_files}} => [@_]; return } -sub block_default_search { push @{$CALLS{block_default_search}} => [@_]; return } - -sub CLEAR_CALLS { %CALLS = () } - -sub GET_CALLS { - return { %CALLS } -} - -use Carp qw/confess/; -confess "Should not see this"; - -1; diff --git a/t/lib/App/Yath/Plugin/Options.pm b/t/lib/App/Yath/Plugin/Options.pm deleted file mode 100644 index 33e382e20..000000000 --- a/t/lib/App/Yath/Plugin/Options.pm +++ /dev/null @@ -1,12 +0,0 @@ -package App::Yath::Plugin::Options; -use strict; -use warnings; - -use App::Yath::Options; - -option foobar => ( - prefix => 'testplugin', - type => 'b', -); - -1; diff --git a/t/unit/App/Yath.t b/t/unit/App/Yath.t deleted file mode 100644 index c2cbbe37b..000000000 --- a/t/unit/App/Yath.t +++ /dev/null @@ -1,263 +0,0 @@ -use Test2::V0 -target => 'App::Yath'; -use Data::Dumper; -use Carp; - -use App::Yath; - -use Test2::Harness::Util qw/clean_path/; - -$ENV{'YATH_SELF_TEST'} = 1; - -subtest init => sub { - my $one = $CLASS->new(argv => [foo => 'bar']); - isa_ok($one, $CLASS); - - isa_ok($one->settings, 'Test2::Harness::Settings'); - - is($one->settings->harness->script, clean_path(__FILE__), "Yath script set to this test file"); - - is($one->_argv, [foo => 'bar'], "Grabbed argv"); - - is($one->config, {}, "Default empty config"); - - my $two = App::Yath->new(); - is($two->_argv, [], "default to empty argv"); -}; - -{ - require App::Yath::Command; - $INC{'App/Yath/Command/NOGEN.pm'} = __FILE__; - $INC{'App/Yath/Command/GEN.pm'} = __FILE__; - - package App::Yath::Command::NOGEN; - use App::Yath::Options; - - option 'verbose' => ( - type => 'c', - prefix => 'foo', - short => 'v', - ); - post sub { $main::POST++ }; - - use Test2::Harness::Util::HashBase qw/settings argv/; - our @ISA = ('App::Yath::Command'); - - sub run { 123 } - - package App::Yath::Command::GEN; - - our @ISA = ('App::Yath::Command::NOGEN'); - - sub generate_run_sub { ('ran gen_run_sub', @_) } -} - -subtest generate_run_sub => sub { - my $one = $CLASS->new(argv => ['GEN']); - - my @out = $one->generate_run_sub('main::RUNSUB'); - is( - \@out, - [ - 'ran gen_run_sub', - 'App::Yath::Command::GEN', - 'main::RUNSUB', - [], - exact_ref($one->settings), - ['GEN'], - ], - "Ran command generate_run_sub with correct args" - ); - - my $two = $CLASS->new(argv => ['NOGEN', '-vv']); - - $two->generate_run_sub('main::RUNSUB'); - is($two->settings->foo->verbose, 2, "Set verbose with CLI args"); - ok(defined(&main::RUNSUB), "Added the runsub to the provided symbol"); - is(main::RUNSUB(), 123, "runsub does what we expect (runs the command run method) and we get the exit value"); - is($main::POST, 1, "Ran post-process callbacks"); -}; - -subtest run_command => sub { - my $one = $CLASS->new(); - - my $cmd = mock {run => undef, name => 'acmd'}; - - is( - dies { $one->run_command($cmd) }, - "Command 'acmd' did not return an exit value.\n", - "Command must return an exit value" - ); - - $cmd->{run} = 12; - - is($one->run_command($cmd), 12, "Returned the proper exit code"); -}; - -subtest command_class => sub { - my $one = $CLASS->new(argv => ['GEN']); - is($one->command_class, 'App::Yath::Command::GEN', "Got command class from args"); - - $one->{_command_class} = 'foo'; - - is($one->command_class, "foo", "A cache is used"); -}; - -subtest load_command => sub { - my $one = $CLASS->new(); - - is($one->load_command('GEN'), 'App::Yath::Command::GEN', "Works for valid command (inline)"); - is($one->load_command('test'), 'App::Yath::Command::test', "Works for valid command (real)"); - - is($one->load_command('gsdfgsdfgsd', check_only => 1), undef, "Missing module is ok in 'check_only' mode"); - - is( - dies { $one->load_command('dgfsdfgsdf') }, - "yath command 'dgfsdfgsdf' not found. (did you forget to install App::Yath::Command::dgfsdfgsdf?)\n", - "Correct message for missing command" - ); - - is( - dies { - local @INC = (sub { die "module failed\n" }); - $one->load_command('jgjgjfdfk'); - }, - "module failed\n", - "If a module load throws an exception we pass it along" - ); -}; - -subtest load_options => sub { - local @INC = (@INC, 't/lib'); - my $one = $CLASS->new(); - - $one->settings->harness->field(no_scan_plugins => 1); - - my $options = $one->load_options(); - is( - $options->included, - { - 'App::Yath::Options::Debug' => 1, - 'App::Yath::Options::PreCommand' => 1, - }, - "Included Debug and PreCommand, but not plugins" - ); - - my $two = $CLASS->new(); - - $two->settings->harness->field(no_scan_plugins => 0); - - warns { $options = $two->load_options() }; - like( - $options->included, - { - 'App::Yath::Options::Debug' => 1, - 'App::Yath::Options::PreCommand' => 1, - 'App::Yath::Plugin::Options' => 1, - }, - "Included Debug and PreCommand, as well as the plugin" - ); - - ref_is($options, $two->load_options, "Cached options result"); -}; - -subtest process_argv => sub { - local @INC = (@INC, 't/lib'); - - my $one = $CLASS->new( - argv => [qw/-Dfoo -Dbar fake -x -y blah uhg/], - config => {fake => [qw/-Dbaz -z/], other => [qw/-noop/]}, - ); - - warns { is($one->process_argv(), $one->_argv, "remaining args are returned") }; - - is($one->command_class, 'App::Yath::Command::fake', "Set command class"); - is( - ${$one->settings->fake}, - { - x => 1, - y => 1, - z => 1, - }, - "Added 'fake' command settings" - ); - - like( - $one->settings->harness->dev_libs, - bag { - item qr/foo$/; - item qr/bar$/; - item qr/baz$/; - }, - "Added the dev libs" - ); - - is($one->_argv, [qw/blah uhg/], "Remaining args"); - - no warnings 'once'; - is($main::POST_HOOK, F(), "Did not run hook yet (requires command instance)"); -}; - -subtest command_from_argv => sub { - my $one = $CLASS->new(); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - - like( - warning { is($one->_command_from_argv, 'test', "Default to test") }, - qr/Defaulting to the 'test' command/, - "Warning about default" - ); - - my $control = mock $CLASS => ( override => [ find_pfile => sub { 1 } ] ); - like( - warning { is($one->_command_from_argv, 'run', "Default to run if we have a persistence file") }, - qr/Persistent runner detected, defaulting to the 'run' command/, - "Warning about default" - ); - $control = undef; - - $one = $CLASS->new(argv => ['-f', '--foo', 'test', '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - is($one->_command_from_argv(), "test", "Found 'test' command"); - is($one->_argv, ['-f', '--foo', '-b', '--bar'], "Command was removed from argv"); - - $one = $CLASS->new(argv => ['-f', '--foo', 'hfajhdajshfj', '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - is($one->_command_from_argv(), "hfajhdajshfj", "Found 'hfajhdajshfj' command"); - is($one->_argv, ['-f', '--foo', '-b', '--bar'], "Command was removed from argv"); - - $one = $CLASS->new(argv => ['-f', '--foo', '--help', '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - is($one->_command_from_argv(), "help", "Found 'help' command"); - is($one->_argv, ['-f', '--foo', '-b', '--bar'], "Command was removed from argv"); - - $one = $CLASS->new(argv => ['-f', '--foo', '-h', '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - is($one->_command_from_argv(), "help", "Found 'help' command"); - is($one->_argv, ['-f', '--foo', '-b', '--bar'], "Command was removed from argv"); - - $one = $CLASS->new(argv => ['-f', '--foo', 'foo.jsonl.bz2', '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - warns { is($one->_command_from_argv(), "replay", "Found 'replay' command because we got a log") }; - is($one->_argv, ['-f', '--foo', 'foo.jsonl.bz2', '-b', '--bar'], "log was not removed from argv"); - - $one = $CLASS->new(argv => ['-f', '--foo', __FILE__, '-b', '--bar']); - $one->settings->harness->vivify_field('persist_file'); - $one->settings->harness->vivify_field('project'); - $one->settings->harness->vivify_field('persist_dir'); - warns { is($one->_command_from_argv(), "test", "Found 'test' command because we got a path") }; - is($one->_argv, ['-f', '--foo', __FILE__, '-b', '--bar'], "path was not removed"); -}; - -done_testing; diff --git a/t/unit/App/Yath/Command/init.t b/t/unit/App/Yath/Command/init.t deleted file mode 100644 index 3b81089fd..000000000 --- a/t/unit/App/Yath/Command/init.t +++ /dev/null @@ -1,48 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Command::init'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -use App::Yath::Tester qw/make_example_dir/; - -use Cwd qw/getcwd/; -my $orig = getcwd(); - -subtest run => sub { - my $dir = make_example_dir(); - chdir($dir); - - unlink('test.pl') or die "Could not unlink test.pl" - if -e 'test.pl'; - - my $stdout = ""; - { - local *STDOUT; - open(STDOUT, '>', \$stdout); - is($CLASS->run(), 0, "Exit of 0"); - ok(-e 'test.pl', "Added test.pl"); - - is($CLASS->run(), 0, "Exit of 0 if we are updating a generated one"); - - unlink('test.pl') or die "Could not unlink test.pl"; - - open(my $fh, '>', 'test.pl') or die "Could not open test.pl"; - print $fh "xx\n"; - close($fh); - } - - is( - $stdout, - "\nWriting test.pl...\n\n\nWriting test.pl...\n\n", - "Saw write info both times" - ); - - is( - dies { $CLASS->run() }, - "'test.pl' already exists, and does not appear to be a yath runner.\n", - "Cannot override a non-generated test.pl" - ); -}; - -done_testing; -chdir($orig); diff --git a/t/unit/App/Yath/Option.t b/t/unit/App/Yath/Option.t deleted file mode 100644 index 9a5e46b4f..000000000 --- a/t/unit/App/Yath/Option.t +++ /dev/null @@ -1,447 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Option'; - -use Test2::Harness::Settings; - -subtest types => sub { - ok($CLASS->valid_type($_), "'$_' is a valid type") for qw/b c s m d D h H/; - ok(!$CLASS->valid_type('x'), "'x' is not a valid type"); - - is($CLASS->canon_type($_), 'b', "Converted '$_' to 'b'") for qw/bool boolean/; - is($CLASS->canon_type($_), 'c', "Converted '$_' to 'c'") for qw/count counter counting/; - is($CLASS->canon_type($_), 's', "Converted '$_' to 's'") for qw/scalar string number/; - is($CLASS->canon_type($_), 'm', "Converted '$_' to 'm'") for qw/multi multiple list array/; - is($CLASS->canon_type($_), 'd', "Converted '$_' to 'd'") for qw/default def/; - is($CLASS->canon_type($_), 'D', "Converted '$_' to 'D'") for qw/multi-def multiple-default list-default array-default/; - is($CLASS->canon_type($_), 'h', "Converted '$_' to 'h'") for qw/hash/; - is($CLASS->canon_type($_), 'H', "Converted '$_' to 'H'") for qw/hash-list/; - - for my $t (qw/s m h H/) { - my $one = bless {type => $t}, $CLASS; - is($one->requires_arg(), T(), "type '$t' requires an arg"); - is($one->allows_arg(), T(), "type '$t' does allow an arg"); - } - - for my $t (qw/d D/) { - my $one = bless {type => $t}, $CLASS; - is($one->requires_arg(), F(), "type '$t' does not require an arg"); - is($one->allows_arg(), T(), "type '$t' does allow an arg"); - } - - for my $t (qw/b c/) { - my $one = bless {type => $t}, $CLASS; - is($one->requires_arg(), F(), "type '$t' does not require an arg"); - is($one->allows_arg(), F(), "type '$t' does not allow an arg"); - } -}; - -subtest init => sub { - like( - dies { $CLASS->new() }, - qr/You must specify 'title' or both 'field' and 'name'/, - "Need 'title', or 'field' and 'name'" - ); - - like( - dies { $CLASS->new(title => 'foo') }, - qr/The 'prefix' attribute is required/, - "prefix is required" - ); - - like( - dies { $CLASS->new(title => 'foo', prefix => 'xxx', alt => 'xxx') }, - qr/The 'alt' attribute must be an array-ref/, - "Alt, when present must be an arrayref" - ); - - my $one = $CLASS->new(title => 'foo-bar_baz', prefix => 'xxx'); - isa_ok($one, [$CLASS], "Instance of $CLASS"); - is($one->title, 'foo-bar_baz', "set title"); - is($one->field, 'foo_bar_baz', "field has underscores"); - is($one->name, 'foo-bar-baz', "name has dashes"); - is($one->type, 'b', "Default type is boolean"); - - $one = $CLASS->new(title => 'foo-bar_baz', prefix => 'xxx', from_plugin => 1); - is($one->title, 'foo-bar_baz', "set title"); - is($one->field, 'foo_bar_baz', "field has underscores"); - is($one->name, 'xxx-foo-bar-baz', "name has dashes, prefix is in place if it is a plugin option"); - is($one->type, 'b', "Default type is boolean"); - - { - package Foo; - Test2::Harness::Util::HashBase->import(qw/bar/); - } - - like( - dies { $CLASS->new(title => 'baz', prefix => 'xxx', builds => 'Foo') }, - qr/class 'Foo' does not have a 'baz' method/, - "If the option is supposed to build a specific class, make sure the class knows" - ); - - ok($CLASS->new(title => 'bar', prefix => 'xxx', builds => 'Foo'), "Construction is fine if build package has the right method"); - - ok($CLASS->new(title => 'bar', prefix => 'xxx', type => 's'), "'s' is a valid type"); - is($CLASS->new(title => 'bar', prefix => 'xxx', type => 'scalar')->type, 's', "'scalar' is a valid type, turns into 's'"); - - like( - dies { $CLASS->new(title => 'bar', prefix => 'xxx', type => 'uhg') }, - qr/Invalid type 'uhg'/, - "Type must be valid" - ); - - is($CLASS->new(title => 'foo', prefix => 'xxx', default => 'foo')->default, 'foo', "Simple string default is fine"); - is($CLASS->new(title => 'foo', prefix => 'xxx', default => 123)->default, 123, "Simple number default is fine"); - is($CLASS->new(title => 'foo', prefix => 'xxx', default => \&T)->default, exact_ref(\&T), "Can use a coderef for default"); - like( - dies { $CLASS->new(title => 'foo', prefix => 'xxx', default => []) }, - qr/'default' must be a simple scalar, or a coderef, got a 'ARRAY/, - "Cannot use a non-coderef ref as a default" - ); - - for my $attr (qw/normalize action/) { - is($CLASS->new(title => 'foo', prefix => 'xxx', $attr => \&T)->$attr, exact_ref(\&T), "Can set $attr to a coderef"); - is($CLASS->new(title => 'foo', prefix => 'xxx', $attr => undef)->$attr, undef, "Can set $attr to undef"); - - like( - dies { $CLASS->new(title => 'foo', prefix => 'xxx', $attr => []) }, - qr/'$attr' must be undef, or a coderef, got 'ARRAY/, - "Cannot use a non-coderef ref with $attr" - ); - - like( - dies { $CLASS->new(title => 'foo', prefix => 'xxx', $attr => 1) }, - qr/'$attr' must be undef, or a coderef, got 'not a ref'/, - "Cannot use a scalar with $attr" - ); - } - - $one = $CLASS->new(title => 'foo', prefix => 'xxx'); - is($one->trace, array { item __PACKAGE__; item __FILE__; item __LINE__ - 1; etc; }, "Got correct trace"); - is($one->category, 'NO CATEGORY - FIX ME', "Default category"); - is($one->description, 'NO DESCRIPTION - FIX ME', "Default description"); - - like( - dies { $CLASS->new(title => 'foo', prefix => 'xxx', foo => 'bar') }, - qr/'foo' is not a valid option attribute/, - "All construction args must be valid" - ); -}; - -subtest applicable => sub { - my $options = 'foo'; - my $one = $CLASS->new(title => 'foo', prefix => 'xxx'); - is($one->applicable($options), T(), "Unless a callback was provided and option is always applicable."); - - my $args; - $one = $CLASS->new(title => 'foo', prefix => 'xxx', applicable => sub {$args = [@_]; 0}); - - is($one->applicable($options), F(), "Used value from callback"); - is($args, [exact_ref($one), $options], "Callback got the necessary args"); -}; - -subtest long_args => sub { - my $one = $CLASS->new(title => 'foo', prefix => 'xxx'); - is([$one->long_args], [qw/foo/], "Got long args"); - - $one = $CLASS->new(title => 'foo', prefix => 'xxx', alt => [qw/a b c/]); - is([$one->long_args], [qw/foo a b c/], "Got long args"); -}; - -subtest option_slot => sub { - my $one = $CLASS->new(title => 'foo', prefix => 'xxx'); - - my $settings = Test2::Harness::Settings->new(); - - ok(my $slot = $one->option_slot($settings), "Got the slot"); - is($$slot, undef, "slot is a reference pointing to a scalar with an undef value"); - is($settings->xxx->foo, undef, "Vivified in settings"); - $$slot = 123; - is($settings->xxx->foo, 123, "Setting the slotref sets it in settings"); - - like( - dies { $one->option_slot() }, - qr/A settings instance is required/, - "Need to pass in settings" - ); -}; - -subtest get_default => sub { - my $new = sub { $CLASS->new(title => 'foo', prefix => 'xxx', @_) }; - is($new->(type => 's')->get_default, undef, "default for scalar is undef"); - is($new->(type => 'd')->get_default, undef, "default for 'd' is undef"); - is($new->(type => 'b')->get_default, 0, "default for boolean is 0"); - is($new->(type => 'c')->get_default, 0, "default for count is 0"); - is($new->(type => 'm')->get_default, [], "default for multi is an empty array"); - is($new->(type => 'D')->get_default, [], "default for multi-d is an empty array"); - is($new->(type => 'h')->get_default, {}, "default for hash is an empty hash"); - is($new->(type => 'H')->get_default, {}, "default for multi-hash is an empty hash"); - - is($new->(type => 's', default => 123)->get_default, 123, "Used simple default"); - is($new->(type => 's', default => sub { 'xxx' })->get_default, 'xxx', "Used default generator"); -}; - -subtest get_normalized => sub { - my $new = sub { $CLASS->new(title => 'foo', prefix => 'xxx', @_) }; - - is($new->(type => 'b')->get_normalized('a'), 1, "Boolean normalized to true"); - is($new->(type => 'b')->get_normalized(''), 0, "Boolean normalized to false"); - - is($new->(type => 's')->get_normalized('foo'), 'foo', "Normalize does not change most things"); - - is($new->(type => 'h')->get_normalized('foo=bar'), ['foo', 'bar'], "Simple hash parse/normalize"); - is($new->(type => 'h')->get_normalized('foo=bar=baz,bat'), ['foo', 'bar=baz,bat'], "Do not do anything special for 'h' values"); - is($new->(type => 'h')->get_normalized('foo'), ['foo', 1], "Value is 1 if nothing is specified"); - - is($new->(type => 'H')->get_normalized('foo=bar'), ['foo', ['bar']], "Simple multi-hash parse/normalize"); - is($new->(type => 'H')->get_normalized('foo=bar=baz,bat'), ['foo', ['bar=baz', 'bat']], "Split 'H' by comma"); - is($new->(type => 'H')->get_normalized('foo'), ['foo', []], "Value is [] if nothing is specified"); -}; - -subtest handle => sub { - require App::Yath::Options; - my $options = App::Yath::Options->new(); - my $new = sub { $CLASS->new(title => 'foo', prefix => 'xxx', @_), Test2::Harness::Settings->new() }; - - my ($one, $settings) = $new->(type => 'c'); - $one->handle(1, $settings, $options); - is($settings->xxx->foo, 1, "increment by 1"); - $one->handle('a', $settings, $options); - is($settings->xxx->foo, 2, "increment by 1 again"); - - ($one, $settings) = $new->(type => 'm'); - $one->handle('a', $settings, $options); - is($settings->xxx->foo, ['a'], "Pushed value"); - $one->handle('b', $settings, $options); - is($settings->xxx->foo, ['a', 'b'], "Pushed value again"); - - ($one, $settings) = $new->(type => 'D'); - $one->handle('a', $settings, $options); - is($settings->xxx->foo, ['a'], "Pushed value"); - $one->handle('b', $settings, $options); - is($settings->xxx->foo, ['a', 'b'], "Pushed value again"); - - ($one, $settings) = $new->(type => 'h'); - $one->handle('foo=bar', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo'], foo => 'bar'}, "Set value and added it to the list key"); - $one->handle('foo=baz', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo'], foo => 'baz'}, "Reset value, not duplicated in the list key"); - $one->handle('fog=baz', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo', 'fog'], foo => 'baz', fog => 'baz'}, "Set second key"); - - ($one, $settings) = $new->(type => 'H'); - $one->handle('foo=bar', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo'], foo => ['bar']}, "Set value and added it to the list key"); - $one->handle('foo=baz,bat', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo'], foo => ['bar', 'baz', 'bat']}, "Added more values"); - $one->handle('fog', $settings, $options); - is($settings->xxx->foo, {'@' => ['foo', 'fog'], foo => ['bar', 'baz', 'bat'], fog => []}, "Set second key"); - - my $args; - ($one, $settings) = $new->(type => 'H', action => sub { - my ($prefix, $field, $raw, $norm, $slot, $settings, $handler) = @_; - $args = [@_]; - $handler->($slot, $norm); - return 'xxx'; - }); - - is($one->handle('foo=baz,bat', $settings, $options), 'xxx', "Returned value from action"); - is($settings->xxx->foo, {'@' => ['foo'], foo => ['baz', 'bat']}, "Set value via handler"); - is( - $args, - [ - $one->prefix, - $one->field, - "foo=baz,bat", - [foo => ['baz', 'bat']], - exact_ref($one->option_slot($settings)), - exact_ref($settings), - meta { prop reftype => 'CODE' }, - exact_ref($options), - ], - "Got args" - ); -}; - -subtest handle_negation => sub { - require App::Yath::Options; - my $options = App::Yath::Options->new(); - my $new = sub { $CLASS->new(title => 'foo', prefix => 'xxx', @_), Test2::Harness::Settings->new() }; - - for my $type (qw/b c/) { - my ($one, $settings) = $new->(type => $type); - $one->handle(1, $settings, $options); - is($settings->xxx->foo, 1, "'$type' Is set"); - $one->handle_negation($settings, $options); - is($settings->xxx->foo, 0, "'$type' Cleared"); - } - - for my $type (qw/m D/) { - my ($one, $settings) = $new->(type => $type); - $one->handle('abc', $settings, $options); - is($settings->xxx->foo, ['abc'], "'$type' Is set"); - $one->handle_negation($settings, $options); - is($settings->xxx->foo, [], "'$type' Cleared"); - } - - for my $type (qw/h H/) { - my ($one, $settings) = $new->(type => $type); - $one->handle('abc', $settings, $options); - is($settings->xxx->foo, {'@' => ['abc'], abc => T()}, "'$type' Is set"); - $one->handle_negation($settings, $options); - is($settings->xxx->foo, {}, "'$type' Cleared"); - } - - my ($one, $settings) = $new->(type => 's'); - $one->handle('abc', $settings, $options); - is($settings->xxx->foo, 'abc', "'s' Is set"); - $one->handle_negation($settings, $options); - is($settings->xxx->foo, undef, "'s' Cleared"); -}; - -subtest trace_string => sub { - my $one = $CLASS->new(prefix => 'xxx', title => 'foo', trace => ['Foo', 'foo.pm', 42]); - is($one->trace_string(), "foo.pm line 42", "Valid trace string"); -}; - -subtest cli_docs => sub { - my $one = $CLASS->new( - type => 'b', - prefix => 'xxx', - title => 'foo', - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - ); - - require Test2::Util::Term; - my $c = mock 'Test2::Util::Term' => ( - override => [term_size => sub { 10 }], # Default to super small to make sure we do something sane - ); - - is($one->cli_docs, "--foo, -F, --no-foo\n This is foo bar baz bat gsdgdsgfsdd", "Got docs"); - - $one = $CLASS->new( - type => 'H', - prefix => 'xxx', - title => 'foo', - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - ); - - chomp(my $res = <<' EOT'); ---foo KEY=VAL1,VAL2,..., --foo=KEY=VAL1,VAL2,..., -F KEY=VAL1,VAL2,... --F=KEY=VAL1,VAL2,..., --no-foo - This is foo bar baz bat gsdgdsgfsdd - - Note: Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together. - EOT - - is($one->cli_docs, $res, "Got more complex docs"); - - $one = $CLASS->new( - type => 'H', - prefix => 'xxx', - title => 'foo', - alt => ['bar', 'baz'], - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - long_examples => [' KEY=VALX,VALY,...', '=KEY=VALX,VALY,...'], - short_examples => [' KEY=VALX,VALY,...', '=KEY=VALX,VALY,...'], - ); - - chomp($res = <<' EOT'); ---foo KEY=VALX,VALY,..., --foo=KEY=VALX,VALY,..., --bar KEY=VALX,VALY,... ---bar=KEY=VALX,VALY,..., --baz KEY=VALX,VALY,..., --baz=KEY=VALX,VALY,... --F KEY=VALX,VALY,..., -F=KEY=VALX,VALY,..., --no-foo - This is foo bar baz bat gsdgdsgfsdd - - Note: Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together. - EOT - - is($one->cli_docs, $res, "Got more complex docs with custom examples"); -}; - -subtest pod_docs => sub { - my $one = $CLASS->new( - type => 'b', - prefix => 'xxx', - title => 'foo', - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - ); - - require Test2::Util::Term; - my $c = mock 'Test2::Util::Term' => ( - override => [term_size => sub { 10 }], # Default to super small to make sure we do something sane - ); - - is($one->pod_docs, <<' EOT', "Got docs"); -=item --foo - -=item -F - -=item --no-foo - -This is foo bar baz bat gsdgdsgfsdd - EOT - - $one = $CLASS->new( - type => 'H', - prefix => 'xxx', - title => 'foo', - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - ); - - is($one->pod_docs, <<' EOT', "Got more complex docs"); -=item --foo KEY=VAL1,VAL2,... - -=item --foo=KEY=VAL1,VAL2,... - -=item -F KEY=VAL1,VAL2,... - -=item -F=KEY=VAL1,VAL2,... - -=item --no-foo - -This is foo bar baz bat gsdgdsgfsdd - -Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together. - EOT - - $one = $CLASS->new( - type => 'H', - prefix => 'xxx', - title => 'foo', - alt => ['bar', 'baz'], - short => 'F', - description => 'This is foo bar baz bat gsdgdsgfsdd', - long_examples => [' KEY=VALX,VALY,...', '=KEY=VALX,VALY,...'], - short_examples => [' KEY=VALX,VALY,...', '=KEY=VALX,VALY,...'], - ); - - is($one->pod_docs, <<' EOT', "Got more complex docs with custom examples"); -=item --foo KEY=VALX,VALY,... - -=item --foo=KEY=VALX,VALY,... - -=item --bar KEY=VALX,VALY,... - -=item --bar=KEY=VALX,VALY,... - -=item --baz KEY=VALX,VALY,... - -=item --baz=KEY=VALX,VALY,... - -=item -F KEY=VALX,VALY,... - -=item -F=KEY=VALX,VALY,... - -=item --no-foo - -This is foo bar baz bat gsdgdsgfsdd - -Can be specified multiple times. If the same key is listed multiple times the value lists will be appended together. - EOT -}; - - -done_testing; diff --git a/t/unit/App/Yath/Options.t b/t/unit/App/Yath/Options.t deleted file mode 100644 index 46eecbb21..000000000 --- a/t/unit/App/Yath/Options.t +++ /dev/null @@ -1,782 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Options'; -require App::Yath::Command; - -subtest sugar => sub { - package Test::Options::One; - use App::Yath::Options; - use Test2::V0 -target => 'App::Yath::Options'; - - imported_ok(qw/post option options option_group include_options/); - - like( - dies { $CLASS->import() }, - qr/Test::Options::One already has an 'options' method/, - "Cannot double-import" - ); - - isa_ok(options(), [$CLASS], "options() returns an instance"); - - my $line; - option_group {prefix => 'foo'}, sub { - option_group {category => 'uhg'}, sub { - $line = __LINE__; - option 'xxx' => (description => 'xxx'); - option 'a_foo' => (description => 'a foo'); - }; - option 'outer' => (description => 'outer'); - }; - - is( - options()->all, - [ - { - type => 'b', - description => 'xxx', - field => 'xxx', - name => 'xxx', - prefix => 'foo', - title => 'xxx', - category => 'uhg', - trace => [__PACKAGE__, __FILE__, $line + 1], - }, - { - type => 'b', - description => 'a foo', - field => 'a_foo', - name => 'a-foo', - prefix => 'foo', - title => 'a_foo', - category => 'uhg', - trace => [__PACKAGE__, __FILE__, $line + 2], - }, - { - type => 'b', - description => 'outer', - field => 'outer', - name => 'outer', - prefix => 'foo', - title => 'outer', - category => 'NO CATEGORY - FIX ME', - trace => [__PACKAGE__, __FILE__, $line + 4], - }, - ], - "Added options, correct traces, prefix from group, nestable", - ); - - like( - dies { option_group { builds => 'A::Fake::Module::Name' }, sub { 1 } }, - qr/Can't locate A.+Fake.+Module.+Name\.pm/, - "'builds' must be a valid module" - ); - - post foo => sub { 1 }; - post bar => sub { 'app-a' }, sub { 2 }; - option_group {applicable => sub { 'app-b' } }, sub { post baz => sub { 3 } }; - - my $posts = options->post_list; - like( - $posts, - [ - ['foo'], - ['bar'], - ['baz'], - ], - "All 3 posts were listed" - ); - is($posts->[0]->[1], undef, "No applicability check for foo"); - is($posts->[0]->[2]->(), 1, "Correct callback for foo"); - is($posts->[1]->[1]->(), 'app-a', "correct applicability check for bar"); - is($posts->[1]->[2]->(), 2, "Correct callback fo bar"); - is($posts->[2]->[1]->(), 'app-b', "correct applicability check for baz (from group)"); - is($posts->[2]->[2]->(), 3, "Correct callback fo baz"); - - like( - dies { post foo => 1 }, - qr/You must provide a callback coderef/, - "Code is required" - ); - - package Test::Options::Two; - use App::Yath::Options; - use Test2::V0 -target => 'App::Yath::Options'; - - include_options 'Test::Options::One'; - - is(options()->all(), Test::Options::One->options()->all(), "Included options"); -}; - -subtest init => sub { - my $one = $CLASS->new(); - isa_ok($one, [$CLASS], "Created an instance"); - - can_ok( - $one, - [qw{ - all lookup pre_list cmd_list post_list post_list_sorted settings args - command_class pending_pre pending_cmd pending_post included set_by_cli - }], - "Attributes" - ); - - like( - $one, - { - all => [], - lookup => {}, - pre_list => [], - cmd_list => [], - post_list => [], - included => {}, - set_by_cli => {}, - }, - "Set defaults", - ); - - isa_ok($one->settings, ['Test2::Harness::Settings'], "Generated a settings object by default"); -}; - -subtest option => sub { - my $one = $CLASS->new(); - - my $trace = [__PACKAGE__, __FILE__, __LINE__ + 1]; - my $opt = $one->option('foo', prefix => 'pre'); - isa_ok($opt, ['App::Yath::Option'], "Got an option instance"); - is($opt->trace, $trace, "Injected the correct trace"); - is($opt->title, 'foo', "Correct title"); - is($opt->prefix, 'pre', "Correct prefix"); - is($one->all, [exact_ref($opt)], "Added the option"); - is($one->cmd_list, [exact_ref($opt)], "Added the option for commands"); - is($one->lookup, {foo => exact_ref($opt)}, "Added option to the lookup"); -}; - -subtest _option => sub { - my $one = $CLASS->new(); - - my $trace = [__PACKAGE__, __FILE__, __LINE__ + 1]; - my $opt = $one->_option($trace, 'foo', prefix => 'pre'); - isa_ok($opt, ['App::Yath::Option'], "Got an option instance"); - is($opt->trace, $trace, "Used the correct trace"); - is($opt->title, 'foo', "Correct title"); - is($opt->prefix, 'pre', "Correct prefix"); - is($one->all, [exact_ref($opt)], "Added the option"); - is($one->cmd_list, [exact_ref($opt)], "Added the option for commands"); - is($one->lookup, {foo => exact_ref($opt)}, "Added option to the lookup"); -}; - -subtest _parse_option_args => sub { - my $one = $CLASS->new(); - - is( - {$one->_parse_option_args('foo')}, - {title => 'foo', type => undef}, - "Parse just title" - ); - - is( - {$one->_parse_option_args('foo=b')}, - {title => 'foo', type => 'b'}, - "Parse title=type" - ); - - is( - {$one->_parse_option_args('foo', 'b')}, - {title => 'foo', type => 'b'}, - "Parse title, type" - ); - - is( - {$one->_parse_option_args('foo', type => 'b', other => 'yes')}, - {title => 'foo', type => 'b', other => 'yes'}, - "Parse title, %opts" - ); -}; - -subtest _parse_option_caller => sub { - no warnings 'once'; - local *My::Caller::A::option_prefix = sub { 'MyPrefix' }; - my $one = $CLASS->new(); - - is( - {$one->_parse_option_caller('My::Caller::A', {})}, - {prefix => 'myprefix'}, - "Found prefix from package, and lowercased it" - ); - - is( - {$one->_parse_option_caller('FAKE', {prefix => 'MyPrefix'})}, - {prefix => 'myprefix'}, - "Found prefix from proto, and lowercased it" - ); - - like( - dies { $one->_parse_option_caller('FAKE', {title => 'foo'}) }, - qr/Could not find an option prefix and option is not top-level \(foo\)/, - "Need a prefix" - ); - - local @App::Yath::Command::fake::ISA = ('App::Yath::Command'); - local *App::Yath::Command::fake::name = sub { 'fake' }; - is( - {$one->_parse_option_caller('App::Yath::Command::fake')}, - {from_command => 'fake'}, - "Found command, prefix not required" - ); - - is( - {$one->_parse_option_caller('App::Yath::Command::fake::Options::Foo')}, - {from_command => 'fake'}, - "Found command (options class for command), prefix not required" - ); - - is( - {$one->_parse_option_caller('App::Yath')}, - {}, - "Special case, prefix not required for App::Yath namespace" - ); - - is( - {$one->_parse_option_caller('App::Yath::Plugin::Foo')}, - {from_plugin => 'App::Yath::Plugin::Foo', prefix => 'foo'}, - "Automatic prefix for plugin" - ); - is( - {$one->_parse_option_caller('App::Yath::Plugin::Foo', {prefix => 'bar'})}, - {from_plugin => 'App::Yath::Plugin::Foo', prefix => 'bar'}, - "Can override automatic plugin prefix" - ); -}; - -subtest include_option => sub { - my $one = $CLASS->new(); - - like( - dies { $one->include_option(bless({title => 'foo', prefix => 'pre'}, 'App::Yath::Option')) }, - qr/Options must have a trace/, - "Need a trace" - ); - - my $opt = App::Yath::Option->new(title => 'foo', prefix => 'foo'); - is($one->include_option($opt), exact_ref($opt), "Added, and returned the reference"); - - like( - $one, - { - lookup => {foo => exact_ref($opt)}, - all => [exact_ref($opt)], - cmd_list => [exact_ref($opt)], - }, - "Added the option and indexed it" - ); -}; - -subtest _index_option => sub { - my $one = $CLASS->new(); - my $opt1 = App::Yath::Option->new(title => 'foo', short => 'f', alt => ['fooo', 'fo'], prefix => 'foo'); - my $opt2 = App::Yath::Option->new(title => 'boo', short => 'b', alt => ['booo', 'bo'], prefix => 'foo'); - - is($one->_index_option($opt1), 4, "indexed into 4 slots"); - is($one->_index_option($opt1), 0, "Double indexing the same opt does not explode, 0 slots"); - is( - $one->lookup, - { - f => exact_ref($opt1), - fo => exact_ref($opt1), - foo => exact_ref($opt1), - fooo => exact_ref($opt1), - }, - "Index has all 4 items", - ); - - is($one->_index_option($opt2), 4, "indexed into 4 slots"); - is($one->_index_option($opt2), 0, "Double indexing the same opt does not explode, 0 slots"); - is( - $one->lookup, - { - f => exact_ref($opt1), - fo => exact_ref($opt1), - foo => exact_ref($opt1), - fooo => exact_ref($opt1), - b => exact_ref($opt2), - bo => exact_ref($opt2), - boo => exact_ref($opt2), - booo => exact_ref($opt2), - }, - "Index has all items", - ); - - my $string = $opt1->trace_string; - like( - dies { $one->_index_option(App::Yath::Option->new(title => 'foo', prefix => 'foo')) }, - qr/Option 'foo' was already defined \(\Q$string\E\)/, - "Cannot add 2 opts with the same long flag" - ); - like( - dies { $one->_index_option(App::Yath::Option->new(title => 'xoo', alt => ['fo'], prefix => 'foo')) }, - qr/Option 'fo' was already defined \(\Q$string\E\)/, - "Cannot add 2 opts with the same long flag (alt)" - ); - like( - dies { $one->_index_option(App::Yath::Option->new(title => 'zoo', short => 'f', prefix => 'foo')) }, - qr/Option 'f' was already defined \(\Q$string\E\)/, - "Cannot add 2 opts with the same short flag" - ); -}; - -subtest _list_option => sub { - my $one = $CLASS->new(); - my $opt1 = App::Yath::Option->new(title => 'foo', prefix => 'xxx'); - my $opt2 = App::Yath::Option->new(title => 'bar', prefix => 'xxx', pre_command => 1); - - ok($one->_list_option($opt1), "listed option 1"); - ok($one->_list_option($opt2), "listed option 2"); - - like( - $one, - { - cmd_list => [exact_ref($opt1)], - pre_list => [exact_ref($opt2)], - }, - "Added both options to the correct lists" - ); -}; - -subtest include => sub { - my $one = $CLASS->new(post_list_sorted => 1); - - like( - dies { $one->include() }, - qr/Include must be an instance of $CLASS, got undef/, - "Must specify what to include" - ); - - like( - dies { $one->include('foo') }, - qr/Include must be an instance of $CLASS, got 'foo'/, - "String is not a valid include" - ); - - like( - dies { $one->include($CLASS) }, - qr/Include must be an instance of $CLASS, got '$CLASS'/, - "Package is not a valid include" - ); - - my $ref = []; - like( - dies { $one->include($ref) }, - qr/Include must be an instance of $CLASS, got '\Q$ref\E'/, - "A reference is not a valid include" - ); - - bless $ref, 'XXX'; - like( - dies { $one->include($ref) }, - qr/Include must be an instance of $CLASS, got '\Q$ref\E'/, - "Must be an instance of $CLASS" - ); - - my $two = $CLASS->new(); - my $opt1 = $two->option('foo', prefix => 'bar'); - my $opt2 = $two->option('baz', prefix => 'bar', pre_command => 1); - my $post = sub { 1 }; - $two->_post(1, undef, $post); - - $one->include($two); - like( - $one, - { - post_list_sorted => F(), - post_list => [[1, undef, exact_ref($post)]], - cmd_list => [exact_ref($opt1)], - pre_list => [exact_ref($opt2)], - all => [exact_ref($opt1), exact_ref($opt2)], - lookup => {baz => exact_ref($opt2), foo => exact_ref($opt1)}, - }, - "Included options and post-callbacks from the second instance" - ); -}; - -subtest include_from => sub { - my $one = $CLASS->new(post_list_sorted => 1); - - my $two = $CLASS->new(); - my $opt1 = $two->option('foo', prefix => 'bar'); - my $opt2 = $two->option('baz', prefix => 'bar', pre_command => 1); - my $post = sub { 1 }; - $two->_post(1, undef, $post); - $two->included->{'fake'} = 2; - - no warnings 'once'; - *Some::Fake::Package::options = sub { $two }; - - $one->include_from('Some::Fake::Package'); - like( - $one, - { - post_list_sorted => F(), - post_list => [[1, undef, exact_ref($post)]], - cmd_list => [exact_ref($opt1)], - pre_list => [exact_ref($opt2)], - all => [exact_ref($opt1), exact_ref($opt2)], - lookup => {baz => exact_ref($opt2), foo => exact_ref($opt1)}, - included => {'fake' => T(), 'Some::Fake::Package' => T()}, - }, - "Included options and post-callbacks from the specified package" - ); - - like( - dies { $one->include_from('Some::Other::Package') }, - qr/Can't locate Some.+Other.+Package\.pm in \@INC/, - "Must be a valid package" - ); -}; - -subtest populate_pre_defaults => sub { - my $one = $CLASS->new(); - - $one->option('noo', prefix => 'x', type => 's'); - $one->option('foo', prefix => 'x', pre_command => 1, type => 's'); - $one->option('bar', prefix => 'x', pre_command => 1, type => 'h'); - $one->option('baz', prefix => 'x', pre_command => 1, type => 's', default => 42); - $one->option('bat', prefix => 'x', pre_command => 1, type => 'm', default => sub { [42] }); - $one->option('ban', prefix => 'x', pre_command => 1, type => 'h', default => sub { {answer => 42} }); - $one->option('bag', prefix => 'x', pre_command => 1, type => 's', default => sub { }); - - $one->populate_pre_defaults(); - - is( - ${$one->settings->x}, - { - baz => 42, - bar => {}, - bat => [42], - ban => {answer => 42}, - - # The field itself is vivified, but no value set, thus it is undef - # This prevents $settings->x->foo from exploding - foo => undef, - - # Default returned an empty list, just vivify, maybe they know what - # they are doing? - bag => undef, - - # Be explicit, this should NOT be populated, not even as undef - noo => DNE(), - }, - "Populated fields as expected", - ); -}; - -subtest populate_cmd_defaults => sub { - my $one = $CLASS->new(); - - $one->option('noo', prefix => 'x', pre_command => 1, type => 's'); - $one->option('foo', prefix => 'x', type => 's'); - $one->option('bar', prefix => 'x', type => 'h'); - $one->option('baz', prefix => 'x', type => 's', default => 42); - $one->option('bat', prefix => 'x', type => 'm', default => sub { [42] }); - $one->option('ban', prefix => 'x', type => 'h', default => sub { {answer => 42} }); - $one->option('bag', prefix => 'x', type => 's', default => sub { }); - - like( - dies { $one->populate_cmd_defaults() }, - qr/The 'command_class' attribute has not yet been set/, - "Need to set command class first" - ); - - push @App::Yath::Command::fake::ISA => 'App::Yath::Command'; - $one->set_command_class('App::Yath::Command::fake'); - $one->populate_cmd_defaults(); - - is( - ${$one->settings->x}, - { - baz => 42, - bar => {}, - bat => [42], - ban => {answer => 42}, - - # The field itself is vivified, but no value set, thus it is undef - # This prevents $settings->x->foo from exploding - foo => undef, - - # Default returned an empty list, just vivify, maybe they know what - # they are doing? - bag => undef, - - # We also process any remaining pre-command ops - noo => undef, - }, - "Populated fields as expected", - ); -}; - -subtest set_args => sub { - my $one = $CLASS->new(); - - ok(!$one->args, "No args yet"); - - $one->set_args(['foo', 'bar']); - is($one->args, ['foo', 'bar'], "Set the args"); - - like( - dies { $one->set_args(['a']) }, - qr/'args' has already been set/, - "Cannot set args a second time", - ); - - is($one->args, ['foo', 'bar'], "Args did not change"); -}; - -subtest _grab_opts => sub { - my $one = $CLASS->new(); - - like( - dies { $one->_grab_opts() }, - qr/The opt_fetch callback is required/, - "Need opts" - ); - - like( - dies { $one->_grab_opts(sub {[]}) }, - qr/The arg type is required/, - "Need arg type" - ); - - like( - dies { $one->_grab_opts(sub {[]}, 'blah') }, - qr/The 'args' attribute has not yet been set/, - "Need args" - ); - - $one = $CLASS->new; - my $opt1 = $one->option('foo', prefix => 'x', type => 'b', short => 'f'); - my $opt2 = $one->option('bar', prefix => 'x', type => 'b', alt => ['ba']); - my $opt3 = $one->option('baz', prefix => 'x', type => 's'); - my $opt4 = $one->option('bat', prefix => 'x', type => 'm'); - my $opt5 = $one->option('ban', prefix => 'x', type => 'd'); - - $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '--', '--bat', 'NO']; - my @out = $one->_grab_opts('all', 'foo'); - - is($one->args, ['xxx', 'blah', '--', '--bat', 'NO'], "Pulled out known args, stopped at --"); - is( - \@out, - [ - [exact_ref($opt1), 'handle', 1], - [exact_ref($opt2), 'handle', 1], - [exact_ref($opt3), 'handle', 'uhg'], - [exact_ref($opt4), 'handle', 'a'], - [exact_ref($opt1), 'handle_negation'], - [exact_ref($opt4), 'handle', 'b'], - [exact_ref($opt5), 'handle', 'y'], - [exact_ref($opt5), 'handle', 1], - ], - "Got actions to take" - ); - - $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '::', '--bat', 'NO']; - @out = $one->_grab_opts('all', 'foo'); - - is($one->args, ['xxx', 'blah', '::', '--bat', 'NO'], "Pulled out known args, stopped at ::"); - is( - \@out, - [ - [exact_ref($opt1), 'handle', 1], - [exact_ref($opt2), 'handle', 1], - [exact_ref($opt3), 'handle', 'uhg'], - [exact_ref($opt4), 'handle', 'a'], - [exact_ref($opt1), 'handle_negation'], - [exact_ref($opt4), 'handle', 'b'], - [exact_ref($opt5), 'handle', 'y'], - [exact_ref($opt5), 'handle', 1], - ], - "Got actions to take" - ); - - $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg']; - like( - dies { $one->_grab_opts('all', 'foo', die_at_non_opt => 1) }, - qr/Invalid foo option: xxx/, - "Died at non-opt", - ); - - $one->{args} = ['-f', '--ba', 'xxx', '--xyz', '--baz=uhg']; - like( - dies { $one->_grab_opts('all', 'foo') }, - qr/Invalid foo option: --xyz/, - "Died at invalid opt", - ); - - $one->{args} = ['-f', '--ba', 'xxx', '--xyz', '--baz=uhg']; - @out = $one->_grab_opts('all', 'foo', passthrough => 1); - - is($one->args, ['xxx', '--xyz'], "Pulled out known args"); - is( - \@out, - [ - [exact_ref($opt1), 'handle', 1], - [exact_ref($opt2), 'handle', 1], - [exact_ref($opt3), 'handle', 'uhg'], - ], - "Got actions to take" - ); -}; - -subtest '*_command_opts' => sub { - my $set_def = 0; - my $control = mock $CLASS => ( - override => [ - populate_cmd_defaults => sub { $set_def++ }, - ], - ); - my $one = $CLASS->new(); - $one->set_command_class('App::Yath::Command'); - - my $opt1 = $one->option('foo', prefix => 'x', type => 'b', short => 'f'); - my $opt2 = $one->option('bar', prefix => 'x', type => 'b', alt => ['ba']); - my $opt3 = $one->option('baz', prefix => 'x', type => 's'); - my $opt4 = $one->option('bat', prefix => 'x', type => 'm'); - my $opt5 = $one->option('ban', prefix => 'x', type => 'D'); - my $opt6 = $one->option('bag', prefix => 'x', type => 's', pre_command => 1); - - $one->{args} = ['-f', '--ba', 'xxx', '--bag=yes', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '--', '--bat', 'NO']; - $one->grab_command_opts($one->all, 'foo'); - - is($one->args, ['xxx', 'blah', '--', '--bat', 'NO'], "Pulled out known args, stopped at --"); - is( - $one->pending_cmd, - [ - [exact_ref($opt1), 'handle', 1], - [exact_ref($opt2), 'handle', 1], - [exact_ref($opt6), 'handle', 'yes'], - [exact_ref($opt3), 'handle', 'uhg'], - [exact_ref($opt4), 'handle', 'a'], - [exact_ref($opt1), 'handle_negation'], - [exact_ref($opt4), 'handle', 'b'], - [exact_ref($opt5), 'handle', 'y'], - [exact_ref($opt5), 'handle', 1], - ], - "Got actions to take, including pre-command options that were not processed yet" - ); - - $one->process_command_opts; - - is($one->pending_cmd, undef, "Nothing left to do"); - - is( - ${$one->settings->x}, - { - foo => FDNE(), - bar => T(), - baz => 'uhg', - bat => ['a', 'b'], - ban => ['y', 1], - bag => 'yes', - }, - "Set the proper settings" - ); -}; - -subtest '*_pre_command_opts' => sub { - my $set_def = 0; - my $control = mock $CLASS => ( - override => [ - populate_pre_defaults => sub { $set_def++ }, - ], - ); - my $one = $CLASS->new(); - - my $opt1 = $one->option('foo', pre_command => 1, prefix => 'x', type => 'b', short => 'f'); - my $opt2 = $one->option('bar', pre_command => 1, prefix => 'x', type => 'b', alt => ['ba']); - my $opt3 = $one->option('baz', pre_command => 1, prefix => 'x', type => 's'); - my $opt4 = $one->option('bat', pre_command => 1, prefix => 'x', type => 'm'); - my $opt5 = $one->option('ban', pre_command => 1, prefix => 'x', type => 'D'); - my $opt6 = $one->option('bag', pre_command => 0, prefix => 'x', type => 'd'); - - $one->{args} = ['-f', '--ba', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', '--bag=yes', 'xxx', 'blah', '--bat', 'NO']; - $one->grab_pre_command_opts($one->all, 'foo'); - - is($one->args, ['--bag=yes', 'xxx', 'blah', '--bat', 'NO'], "Pulled out known args, stopped at non-opt"); - is( - $one->pending_pre, - [ - [exact_ref($opt1), 'handle', 1], - [exact_ref($opt2), 'handle', 1], - [exact_ref($opt3), 'handle', 'uhg'], - [exact_ref($opt4), 'handle', 'a'], - [exact_ref($opt1), 'handle_negation'], - [exact_ref($opt4), 'handle', 'b'], - [exact_ref($opt5), 'handle', 'y'], - [exact_ref($opt5), 'handle', 1], - ], - "Got actions to take, did not grab command options" - ); - - $one->process_pre_command_opts; - - is($one->pending_pre, undef, "Nothing left to do"); - - is( - ${$one->settings->x}, - { - foo => FDNE(), - bar => T(), - baz => 'uhg', - bat => ['a', 'b'], - ban => ['y', 1], - bag => DNE(), - }, - "Set the proper settings" - ); -}; - -subtest set_command_class => sub { - my $one = $CLASS->new(); - - ok(!$one->command_class, "No command class yet"); - - require App::Yath::Command::test; - my $cmd = bless {}, 'App::Yath::Command::test'; - $one->set_command_class($cmd); - is($one->command_class, 'App::Yath::Command::test', "Can set via a blessed command instance"); - - like( - dies { $one->set_command_class() }, - qr/Command class has already been set/, - "Cannot change command class once set." - ); - - ok($one->included->{'App::Yath::Command::test'}, "Included options from the command"); - - $one = $CLASS->new(); - $one->set_command_class('App::Yath::Command::test'); - is($one->command_class, 'App::Yath::Command::test', "Can set via a class name"); - - $one = $CLASS->new(); - like( - dies { $one->set_command_class('Test2::Harness::Util') }, - qr/Invalid command class: Test2::Harness::Util/, - "Must be a valid command class" - ); -}; - -subtest post => sub { - my $one = $CLASS->new(post_list_sorted => 1); - - my $sub = sub { 'foo' }; - $one->_post(undef, undef, $sub); - ok(!$one->post_list_sorted, "List is no longer considered sorted when we add an item"); - is($one->post_list, [[0, undef, exact_ref($sub)]], "Added item to post list"); - - like( - dies { $one->process_option_post_actions }, - qr/The 'args' attribute has not yet been set/, - "Need args first" - ); - - $one = $CLASS->new(); - $one->set_args(['foo']); -}; - -done_testing; diff --git a/t/unit/App/Yath/Plugin.t b/t/unit/App/Yath/Plugin.t deleted file mode 100644 index 4eb6ea736..000000000 --- a/t/unit/App/Yath/Plugin.t +++ /dev/null @@ -1,13 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Plugin'; - -isa_ok($CLASS, ['Test2::Harness::Plugin'], "Subclasses Test2::Harness::Plugin"); - -can_ok($CLASS, ['finish'], "finish() is defined"); -is([$CLASS->finish], [], "finish returns an empty list in list context"); -is($CLASS->finish, undef, "finish returns undef in scalar context"); - -ok(!$CLASS->can('sort_files'), "sort_files is not defined by default"); -ok(!$CLASS->can('sort_files_2'), "sort_files_2 is not defined by default"); -ok(!$CLASS->can('handle_event'), "handle_event is not defined by default"); - -done_testing; diff --git a/t/unit/App/Yath/Plugin/Git.script b/t/unit/App/Yath/Plugin/Git.script deleted file mode 100755 index 85f0e0005..000000000 --- a/t/unit/App/Yath/Plugin/Git.script +++ /dev/null @@ -1,178 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; - -my $args = join ' ' => @ARGV; - -my $afile = <<'EOT'; -diff --git a/a.file b/a.file -index a7175683..7646fa7b 100644 ---- a/a.file -+++ b/a.file -@@ garbage @@ - package A; - sub sub1 { -- my ($self) = @_; -+ my $self = shift; - ... - } - - sub sub2 { - ... - } - -+my @foo = ("X", "Y"); - -- sub sub3 { ... } - --my @foo = ("X", "Y"); - - 1; -EOT - -my $bfile = <<'EOT'; -diff --git a/b.file b/b.file -index a7175683..7646fa7b 100644 ---- a/b.file -+++ b/b.file -@@ garbage @@ - package B; - -+our $global = "yes"; - - sub sub1 { -- my ($self) = @_; -+ my $self = shift; - ... - } - - sub sub2 { - ... - } - - 1; -EOT - -my $cfile = <<'EOT'; -diff --git a/c.file b/c.file -index a7175683..7646fa7b 100644 ---- a/c.file -+++ b/c.file -@@ garbage @@ - package C; - - sub sub1 { -- my ($self) = @_; -+ my $self = shift; - ... - } - - sub sub2 { - ... - } - - 1; -EOT - -my %out = ( - 'rev-parse HEAD' => [0, "4570988f2c2bd26a1691a82766d5bf5c7524bcea\n"], - 'rev-parse --short HEAD' => [0, "4570988\n"], - 'status -s' => [0, " M lib/App/Yath/Plugin/Git.pm\n"], - 'rev-parse --abbrev-ref HEAD' => [0, "my.branch.foo\n"], - - 'merge-base --is-ancestor HEAD master' => [1, ""], - 'diff HEAD --name-only' => [0, ""], - 'diff -U1000000 -W --minimal HEAD' => [0, ""], - - 'merge-base --is-ancestor HEAD^ master' => [1, ""], - 'diff HEAD^ --name-only' => [0, "a.file\n"], - 'diff -U1000000 -W --minimal HEAD^' => [0, $afile], - - 'merge-base --is-ancestor HEAD^^ master' => [1, ""], - 'diff HEAD^^ --name-only' => [0, "a.file\nb.file\n"], - 'diff -U1000000 -W --minimal HEAD^^' => [0, $afile . $bfile], - - 'merge-base --is-ancestor HEAD^^^ master' => [0, ""], - 'diff HEAD^^^ --name-only' => [0, "a.file\nb.file\nc.file\n"], - 'diff -U1000000 -W --minimal HEAD^^^' => [0, $afile . $bfile . $cfile], -); - -if (my $res = $out{$args}) { - my ($exit, $text) = @$res; - print $text; - exit $exit; -} - -print STDERR "Invalid args: $args\n"; -exit 1; - -__END__ - -diff --git a/lib/App/Yath/Plugin/Git.pm b/lib/App/Yath/Plugin/Git.pm -index a7175683..7646fa7b 100644 ---- a/lib/App/Yath/Plugin/Git.pm -+++ b/lib/App/Yath/Plugin/Git.pm -@@ -1,170 +1,218 @@ - package App::Yath::Plugin::Git; - use strict; - use warnings; - - our $VERSION = '1.000045'; - - use IPC::Cmd qw/can_run/; - use Test2::Harness::Util::IPC qw/run_cmd/; - use parent 'App::Yath::Plugin'; - - use App::Yath::Options; - - option_group {prefix => 'git', category => "Git Options"} => sub { - option change_base => ( - type => 's', - description => "Find files changed by all commits in the current branch from most recent stopping when a commit is found that is also present in the history of -the branch/commit specified as the change base.", - long_examples => [" master", " HEAD^", " df22abe4"], - ); - }; - - my $GIT_CMD = can_run('git'); - sub git_cmd { $ENV{GIT_COMMAND} || $GIT_CMD } - - sub git_output { - my $class = shift; - my (@args) = @_; - - my $cmd = $class->git_cmd or return; - - my ($rh, $wh, $irh, $iwh); - pipe($rh, $wh) or die "No pipe: $!"; - pipe($irh, $iwh) or die "No pipe: $!"; - my $pid = run_cmd(stderr => $iwh, stdout => $wh, command => [$cmd, @args]); -- waitpid($pid, 0); -- return if $?; - - close($wh); - close($iwh); -+ -+ waitpid($pid, 0); -+ if($?) { -+ print STDERR <$irh>; -+ return; -+ } -+ - close($irh); - - return <$rh>; - } - - sub inject_run_data { - my $class = shift; - my %params = @_; - - my $meta = $params{meta}; - my $fields = $params{fields}; - - my $long_sha = $ENV{GIT_LONG_SHA}; - my $short_sha = $ENV{GIT_SHORT_SHA}; - my $status = $ENV{GIT_STATUS}; - my $branch = $ENV{GIT_BRANCH}; - diff --git a/t/unit/App/Yath/Plugin/Git.t b/t/unit/App/Yath/Plugin/Git.t deleted file mode 100755 index bff2030c9..000000000 --- a/t/unit/App/Yath/Plugin/Git.t +++ /dev/null @@ -1,173 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Plugin::Git'; -use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS/; -# HARNESS-DURATION-SHORT - -use Test2::Harness::Settings; - -subtest NOTHING => sub { - my $control = mock $CLASS => ( - override => [ - can_run => sub { undef }, - git_cmd => sub { return }, - ], - ); - - local $ENV{GIT_COMMAND}; - local $ENV{GIT_LONG_SHA}; - local $ENV{GIT_SHORT_SHA}; - local $ENV{GIT_STATUS}; - local $ENV{GIT_BRANCH}; - - my $meta = {}; - my $fields = []; - $CLASS->inject_run_data(meta => $meta, fields => $fields); - - ok(!$meta->{git}, "no git added to meta"); - is(@$fields, 0, "No fields added"); -}; - -subtest ENV => sub { - my $script = __FILE__; - $script =~ s/\.t$/\.script/; - local $ENV{GIT_COMMAND} = $script; - local $ENV{GIT_LONG_SHA} = "1230988f2c2bd26a1691a82766d5bf5c7524b123"; - local $ENV{GIT_SHORT_SHA} = "1230988"; - local $ENV{GIT_STATUS} = " M lib/App/Yath/Command.pm"; - local $ENV{GIT_BRANCH} = "my.super-long-branch-name-needs-to-be-trimmed"; - - my $meta = {}; - my $fields = []; - $CLASS->inject_run_data(meta => $meta, fields => $fields); - - is( - $meta, - { - git => { - branch => 'my.super-long-branch-name-needs-to-be-trimmed', - sha => '1230988f2c2bd26a1691a82766d5bf5c7524b123', - status => ' M lib/App/Yath/Command.pm', - }, - }, - "Added git info to meta-data" - ); - - is( - $fields, - [ - { - data => $meta->{git}, - details => 'my.super-long-branch', - name => 'git', - raw => 'my.super-long-branch-name-needs-to-be-trimmed', - } - ], - "Added git field", - ); -}; - -subtest CMD => sub { - my $script = __FILE__; - $script =~ s/\.t$/\.script/; - local $ENV{GIT_COMMAND} = $script; - local $ENV{GIT_LONG_SHA}; - local $ENV{GIT_SHORT_SHA}; - local $ENV{GIT_STATUS}; - local $ENV{GIT_BRANCH}; - - my $meta = {}; - my $fields = []; - $CLASS->inject_run_data(meta => $meta, fields => $fields); - - is( - $meta, - { - git => { - branch => 'my.branch.foo', - sha => '4570988f2c2bd26a1691a82766d5bf5c7524bcea', - status => ' M lib/App/Yath/Plugin/Git.pm', - }, - }, - "Added git info to meta-data" - ); - - is( - $fields, - [ - { - data => $meta->{git}, - details => 'my.branch.foo', - name => 'git', - raw => 'my.branch.foo', - } - ], - "Added git field", - ); -}; - -subtest MIX => sub { - my $script = __FILE__; - $script =~ s/\.t$/\.script/; - local $ENV{GIT_COMMAND} = $script; - local $ENV{GIT_LONG_SHA} = "1230988f2c2bd26a1691a82766d5bf5c7524b123"; - local $ENV{GIT_SHORT_SHA}; - local $ENV{GIT_STATUS}; - local $ENV{GIT_BRANCH}; - - my $meta = {}; - my $fields = []; - $CLASS->inject_run_data(meta => $meta, fields => $fields); - - is( - $meta, - { - git => { - branch => 'my.branch.foo', - sha => '1230988f2c2bd26a1691a82766d5bf5c7524b123', - status => ' M lib/App/Yath/Plugin/Git.pm', - }, - }, - "Added git info to meta-data" - ); - - is( - $fields, - [ - { - data => $meta->{git}, - details => 'my.branch.foo', - name => 'git', - raw => 'my.branch.foo', - } - ], - "Added git field", - ); -}; - -#subtest changed_files => sub { -# my $settings = Test2::Harness::Settings->new(); -# $settings->define_prefix('git'); -# $settings->git->vivify_field('change_base'); -# -# my $script = __FILE__; -# $script =~ s/\.t$/\.script/; -# local $ENV{GIT_COMMAND} = $script; -# -# is( -# [$CLASS->changed_files($settings)], -# [['a.file', '*', 'sub1', 'sub3']], -# "Got changed file" -# ); -# -# $settings->git->field(change_base => 'master'); -# is( -# [$CLASS->changed_files($settings)], -# [ -# ['a.file', '*', 'sub1', 'sub3'], -# ['b.file', '*', 'sub1'], -# ['c.file', 'sub1'], -# ], -# "Got changed files from change_base" -# ); -#}; - -done_testing; diff --git a/t/unit/App/Yath/Plugin/SysInfo.t b/t/unit/App/Yath/Plugin/SysInfo.t deleted file mode 100644 index cb5872b21..000000000 --- a/t/unit/App/Yath/Plugin/SysInfo.t +++ /dev/null @@ -1,116 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Plugin::SysInfo'; -use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS/; -# HARNESS-DURATION-SHORT - -my $control = mock $CLASS => ( - override => [ - hostname => sub { 'foo.bar.baz-22.superlongnamewedonotwantseen.evenlonger.holycow.net' }, - ], -); - -local *App::Yath::Plugin::SysInfo::Config = { - 'useperlio' => 'define', - 'use64bitint' => 'define', - 'use64bitall' => 'define', - 'useithreads' => 'define', - 'osname' => 'linux', - 'archname' => 'x86_64-linux', - 'usemultiplicity' => undef, - 'version' => '1.2.3', - 'uselongdouble' => undef, -}; - -local $ENV{USER} = 'bob'; -local $ENV{SHELL} = '/bin/shell'; -local $ENV{TERM} = 'myterm'; - -my $meta = {}; -my $fields = []; - -my $one = $CLASS->new(); -$one->inject_run_data(meta => $meta, fields => $fields); - -is( - $fields, - [ - { - name => 'sys', - details => 'foo.bar.baz-22', - raw => 'foo.bar.baz-22.superlongnamewedonotwantseen.evenlonger.holycow.net', - - data => { - hostname => 'foo.bar.baz-22.superlongnamewedonotwantseen.evenlonger.holycow.net', - ipc => { - can_fork => CAN_FORK(), - can_really_fork => CAN_REALLY_FORK(), - can_sigsys => CAN_SIGSYS(), - can_thread => CAN_THREAD(), - }, - env => { - shell => '/bin/shell', - term => 'myterm', - user => 'bob', - }, - config => { - archname => 'x86_64-linux', - osname => 'linux', - use64bitall => 'define', - use64bitint => 'define', - useithreads => 'define', - uselongdouble => undef, - usemultiplicity => undef, - useperlio => 'define', - version => '1.2.3', - } - }, - } - - ], - "Got expected fields" -); - -$meta = {}; -$fields = []; -$one = $CLASS->new(host_short_pattern => "bar\\.baz-\\d+"); -$one->inject_run_data(meta => $meta, fields => $fields); - -is( - $fields, - [ - { - name => 'sys', - details => 'bar.baz-22', - raw => 'foo.bar.baz-22.superlongnamewedonotwantseen.evenlonger.holycow.net', - - data => { - hostname => 'foo.bar.baz-22.superlongnamewedonotwantseen.evenlonger.holycow.net', - ipc => { - can_fork => CAN_FORK(), - can_really_fork => CAN_REALLY_FORK(), - can_sigsys => CAN_SIGSYS(), - can_thread => CAN_THREAD(), - }, - env => { - shell => '/bin/shell', - term => 'myterm', - user => 'bob', - }, - config => { - archname => 'x86_64-linux', - osname => 'linux', - use64bitall => 'define', - use64bitint => 'define', - useithreads => 'define', - uselongdouble => undef, - usemultiplicity => undef, - useperlio => 'define', - version => '1.2.3', - } - }, - } - - ], - "Got expected fields, including custom hostname short filter" -); - -done_testing; diff --git a/t/unit/App/Yath/Util.t b/t/unit/App/Yath/Util.t deleted file mode 100644 index 386eec072..000000000 --- a/t/unit/App/Yath/Util.t +++ /dev/null @@ -1,159 +0,0 @@ -use Test2::V0 -target => 'App::Yath::Util'; -use Test2::Tools::Spec; - -use Test2::Util qw/CAN_REALLY_FORK/; -use Test2::Tools::GenTemp qw/gen_temp/; -use Test2::Harness::Util qw/clean_path/; -use File::Temp qw/tempfile/; -use Cwd qw/cwd/; - -use File::Spec; - -use App::Yath::Util qw{ - find_pfile - is_generated_test_pl - fit_to_width - isolate_stdout - find_yath - find_in_updir -}; - -imported_ok qw{ - find_pfile - is_generated_test_pl - fit_to_width - isolate_stdout - find_yath - find_in_updir -}; - -my $initial_dir = cwd(); -after_each chdir => sub { - chdir($initial_dir); -}; - -tests find_yath => sub { - local $App::Yath::Script::SCRIPT = 'foobar'; - is(find_yath, 'foobar', "Use \$App::Yath::Script::SCRIPT if set"); - - $App::Yath::Script::SCRIPT = undef; - - my $tmp = gen_temp('scripts' => {'yath' => 'xxx'}); - my $yath = clean_path(File::Spec->catfile($tmp, 'scripts', 'yath')); - chdir($tmp); - eval { chmod(0755, File::Spec->catfile($tmp, 'scripts', 'yath')); 1 } or warn $@; - is(find_yath, $yath, "found yath script in scripts/ dir"); - is($App::Yath::Script::SCRIPT, $yath, "cached result"); - - my $tmp2 = gen_temp(); - chdir($tmp2); - - $App::Yath::Script::SCRIPT = undef; - local *App::Yath::Util::Config = {}; - like( - dies { find_yath }, - qr/Could not find yath in Config paths/, - "No yath found" - ); - - local *App::Yath::Util::Config = { - scriptdir => File::Spec->catdir($tmp, 'scripts'), - }; - like(find_yath, qr{\Q$yath\E$}, "Found it in a config path"); -}; - -tests isolate_stdout => sub { - my ($stdout_r, $stdout_w, $stderr_r, $stderr_w); - pipe($stdout_r, $stdout_w) or die "Could not open pipe: $!"; - pipe($stderr_r, $stderr_w) or die "Could not open pipe: $!"; - - my $pid = fork; - die "Could not fork" unless defined $pid; - - unless ($pid) { # child - close($stdout_r); - close($stderr_r); - open(STDOUT, '>&', $stdout_w) or die "Could not redirect STDOUT"; - open(STDERR, '>&', $stderr_w) or die "Could not redirect STDOUT"; - my $fh = isolate_stdout(); - - print $fh "Should go to STDOUT\n"; - print "Should go to STDERR 1\n"; - print STDOUT "Should go to STDERR 2\n"; - print STDERR "Should go to STDERR 3\n"; - - exit 0; - } - - close($stdout_w); - close($stderr_w); - waitpid($pid, 0); - is($?, 0, "Clean exit"); - - is( - [<$stdout_r>], - ["Should go to STDOUT\n"], - "Got expected STDOUT" - ); - is( - [<$stderr_r>], - [ - "Should go to STDERR 1\n", - "Should go to STDERR 2\n", - "Should go to STDERR 3\n", - ], - "Got expected STDERR" - ); -} if CAN_REALLY_FORK; - -subtest is_generated_test_pl => sub { - ok(!is_generated_test_pl(__FILE__), "This is not a generated test file"); - - my ($fh, $name) = tempfile(UNLINK => 1); - print $fh "use strict;\nuse warnings;\n# THIS IS A GENERATED YATH RUNNER TEST\ndfasdafas\n"; - close($fh); - ok(is_generated_test_pl($name), "Found a generated file"); -}; - -subtest find_in_updir => sub { - my $tmp = gen_temp( - thefile => 'xxx', - nest => { - nest_a => { thefile => 'xxx' }, - nest_b => {}, - }, - ); - - chdir(File::Spec->catdir($tmp, 'nest', 'nest_a')) or die "$!"; - my $file = File::Spec->catfile($tmp, 'nest', 'nest_a', 'thefile'); - like(find_in_updir('thefile'), qr{\Q$file\E$}, "Found file in expected spot"); - - chdir(File::Spec->catdir($tmp, 'nest', 'nest_b')) or die "$!"; - $file = File::Spec->catfile($tmp, 'thefile'); - like(find_in_updir('thefile'), qr{\Q$file\E$}, "Found file in expected spot"); -}; - -subtest fit_to_width => sub { - is(fit_to_width(100, " ", "hello there"), "hello there", "No change for short string"); - is(fit_to_width(2, " ", "hello there"), "hello\nthere", "Split across multiple lines"); - - is( - fit_to_width(20, " ", "hello there, this is a longer string that needs splitting."), - "hello there, this is\na longer string that\nneeds splitting.", - "Split across multiple lines" - ); - - is( - fit_to_width(100, " ", ["hello there", "this is a", "longer string that", "needs no splitting."]), - "hello there this is a longer string that needs no splitting.", - "Split across multiple lines" - ); - - is( - fit_to_width(50, " ", ["hello there", "this is a", "longer string that", "needs splitting."]), - "hello there this is a longer string that\nneeds splitting.", - "Split across multiple lines" - ); -}; - -done_testing; diff --git a/t/unit/Test2/Harness/Runner/DepTracer.t b/t/unit/Test2/Harness/Runner/DepTracer.t deleted file mode 100644 index 0e13a8ff6..000000000 --- a/t/unit/Test2/Harness/Runner/DepTracer.t +++ /dev/null @@ -1,97 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Runner::DepTracer'; -# HARNESS-NO-PRELOAD - -BEGIN { skip_all 'TODO' } - -use ok $CLASS; - -unshift @INC => 't/lib'; - -subtest require_hook => sub { - my $one = $CLASS->new; - isa_ok($one, [$CLASS], "Made a new instance"); - ok(!$one->real_require, "Did not find an existing require hook"); - - my $two = $CLASS->new; - ref_is($one->my_require, $two->real_require, "Found the existing require hook"); - - require xxx; - - is($one->loaded, {}, "Nothing tracked yet"); - - $one->start; - - # use eval so we do not pre-bind the require - eval qq(#line ${ \__LINE__ } "${ \__FILE__ }"\nrequire baz; 1) or die $@; - - is($one->loaded, {map { $_ => T } qw/baz.pm foo.pm bar.pm/}, "Loaded 3 modules"); - - is( - $one->dep_map, { - 'baz.pm' => [['main', 't/Test2/Harness/Runner/DepTracer.t']], - 'foo.pm' => [['baz', 't/lib/baz.pm'], ['bar', 't/lib/bar.pm']], - 'bar.pm' => [['baz', 't/lib/baz.pm']], - }, - "Built dep-map" - ); - - $one->stop; - - eval "require Data::Dumper; 1" or die $@; - - is($one->loaded, {map { $_ => T } qw/baz.pm foo.pm bar.pm/}, "Did not track Data::Dumper"); - - $one->clear_loaded; - $one->start; - - eval "use 5.8.9; 1" or die $@; - - is($one->loaded, {}, "Did not track from version import"); -}; - -subtest inc_hook => sub { - my $one = $CLASS->new; - isa_ok($one, [$CLASS], "Made a new instance"); - ok($one->real_require, "Did find an existing require hook"); - - my $two = $CLASS->new; - ref_is($one->my_require, $two->real_require, "Found the existing require hook"); - - require xxx; - - is($one->loaded, {}, "Nothing tracked yet"); - - $one->start; - - # use eval so we do not pre-bind the require - eval qq(#line ${ \__LINE__ } "${ \__FILE__ }"\nCORE::require('baz_core.pm'); 1) or die $@; - - is($one->loaded, {map { $_ => T } qw/baz_core.pm foo_core.pm bar_core.pm/}, "Loaded 3 modules"); - - is( - $one->dep_map, { - 'baz_core.pm' => [['main', 't/Test2/Harness/Runner/DepTracer.t']], - # The @INC hook is limited, it can catch hidden loads for watching, - # but it cannot trace deps when a thing is loaded more than once. - 'foo_core.pm' => [['baz_core', 't/lib/baz_core.pm']], #, ['bar', 't/lib/bar_core.pm']], - 'bar_core.pm' => [['baz_core', 't/lib/baz_core.pm']], - }, - "Built dep-map" - ); - - $one->stop; - - eval "CORE::require('yyy.pm'); 1" or die $@; - - is($one->loaded, {map { $_ => T } qw/baz_core.pm foo_core.pm bar_core.pm/}, "Did not track yyy"); - - $one->clear_loaded; - $one->start; - - eval "use 5.8.9; 1" or die $@; - - is($one->loaded, {}, "Did not track from version import"); -}; - - -done_testing; diff --git a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/.sharedjobslots.yml b/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/.sharedjobslots.yml deleted file mode 100644 index 3bfb3b335..000000000 --- a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/.sharedjobslots.yml +++ /dev/null @@ -1,45 +0,0 @@ ---- -COMMON: - state_file: /tmp/yath-state-config-test - algorithm: fair - max_slots: 4 - max_slots_per_job: 2 - max_slots_per_run: 4 - default_slots_per_run: 2 - default_slots_per_job: 2 - -DEFAULT: - default_slots_per_run: 1 - default_slots_per_job: 1 - -foo: - max_slots: 13 - max_slots_per_job: 5 - max_slots_per_run: 13 - default_slots_per_run: 3 - default_slots_per_job: 2 - -bar: - max_slots: 8 - max_slots_per_job: 2 - max_slots_per_run: 6 - default_slots_per_run: 4 - default_slots_per_job: 2 - state_umask: 0077 - -baz: - max_slots: 64 - max_slots_per_job: 32 - max_slots_per_run: 64 - default_slots_per_run: 64 - default_slots_per_job: 32 - algorithm: first - -bat: - -ban: - use_common: 0 - -baf: - max_slots: 7 - use_common: 0 diff --git a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/Config.t b/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/Config.t deleted file mode 100644 index 14499bf51..000000000 --- a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/Config.t +++ /dev/null @@ -1,109 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Runner::Resource::SharedJobSlots::Config'; -use Test2::Harness::Runner::Resource::SharedJobSlots::Config; - -my $dir = __FILE__; -$dir =~ s{Config\.t$}{}g; -chdir($dir) or die "Could not chdir ($dir): $!"; - -sub CONFIG { - return { - DEFAULT => { - default_slots_per_run => 1, - default_slots_per_job => 1, - }, - COMMON => { - algorithm => 'fair', - state_file => '/tmp/yath-state-config-test', - max_slots => 4, - max_slots_per_run => 4, - max_slots_per_job => 2, - default_slots_per_run => 2, - default_slots_per_job => 2, - }, - foo => { - max_slots => 13, - max_slots_per_run => 13, - max_slots_per_job => 5, - default_slots_per_run => 3, - default_slots_per_job => 2, - }, - bar => { - max_slots => 8, - max_slots_per_run => 6, - max_slots_per_job => 2, - default_slots_per_run => 4, - default_slots_per_job => 2, - state_umask => '0077', - }, - baz => { - algorithm => 'first', - max_slots => 64, - max_slots_per_run => 64, - max_slots_per_job => 32, - default_slots_per_run => 64, - default_slots_per_job => 32, - }, - bat => undef, - ban => { - use_common => '0', - }, - baf => { - use_common => 0, - max_slots => 7, - }, - }; -} - -my $one = $CLASS->find(host => 'foo'); - -like( - $one, - hash { - field host => 'foo'; - field common_conf => CONFIG()->{COMMON}; - field host_conf => CONFIG()->{foo}; - field config_file => '.sharedjobslots.yml'; - field config_raw => CONFIG(); - etc; - }, - "Found the config file, loaded options" -); - -is($one->state_umask, 0007, "Got default umask"); -is($one->state_file, '/tmp/yath-state-config-test', "Got state file from common"); -is($one->algorithm, '_redistribute_fair', "got algorithm from common"); -is($one->max_slots, 13, "got max slots from host"); -is($one->min_slots_per_run, 0, "default min slots per run at 0"); -is($one->max_slots_per_job, 5, "got max slots per job from host"); -is($one->max_slots_per_run, 13, "got max slots per run from host"); -is($one->default_slots_per_job, 2, "got default slots per job from host"); -is($one->default_slots_per_run, 3, "got default slots per run from host"); - -$one = $CLASS->find(host => 'bar'); -is($one->state_umask, '0077', "Got host umask"); - -$one = $CLASS->find(host => 'bat'); -is($one->algorithm, '_redistribute_fair', "got algorithm from common"); -is($one->max_slots, 4, "got max slots from common"); -is($one->min_slots_per_run, 0, "default min slots per run at 0"); -is($one->max_slots_per_job, 2, "got max slots per job from common"); -is($one->max_slots_per_run, 4, "got max slots per run from common"); -is($one->default_slots_per_job, 2, "got default slots per job from common"); -is($one->default_slots_per_run, 2, "got default slots per run from common"); - -$one = $CLASS->find(host => 'baf'); -is($one->algorithm, '_redistribute_fair', "got algorithm from default"); -is($one->max_slots, 7, "got max slots from host"); -is($one->min_slots_per_run, 0, "default min slots per run at 0"); -is($one->max_slots_per_job, 7, "got max slots per job from default"); -is($one->max_slots_per_run, 7, "got max slots per run from default"); -is($one->default_slots_per_job, 7, "got default slots per job from default"); -is($one->default_slots_per_run, 7, "got default slots per run from default"); - -is( - dies { $one = $CLASS->find(host => 'ban') }, - "'max_slots' not set in '\.sharedjobslots\.yml' for host 'ban' or under 'COMMON' config.\n", - "Need a value for max slots" -); - -done_testing; diff --git a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/State.t b/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/State.t deleted file mode 100644 index 29d8f57e4..000000000 --- a/t/unit/Test2/Harness/Runner/Resource/SharedJobSlots/State.t +++ /dev/null @@ -1,667 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Runner::Resource::SharedJobSlots::State'; -use File::Temp qw/tempfile/; - -use ok $CLASS; - -sub inst { - my %params = @_; - - my $state_file = $params{state_file}; - - unless ($state_file) { - my $fh; - ($fh, $state_file) = tempfile(UNLINK => 1); - close($fh); - } - - return $CLASS->new( - state_file => $state_file, - max_slots => 10, - max_slots_per_job => 3, - max_slots_per_run => 9, - runner_pid => $$, - %params, - ); -} - -subtest init_checks => sub { - for my $field (qw/state_file max_slots max_slots_per_job max_slots_per_run/) { - my %proto = ( - state_file => '/dev/null', - max_slots => 100, - max_slots_per_job => 5, - max_slots_per_run => 50, - ); - - # Remove the field we are testing for. - delete $proto{$field}; - - like( - dies { $CLASS->new(%proto) }, - qr/'$field' is a required attribute/, - "Require '$field' be provided" - ); - } - - my $one = inst(); - isa_ok($one, [$CLASS], "Created an instance"); -}; - -subtest init_state => sub { - my $one = inst(runner_id => 'one'); - my $state = $one->transaction('w'); - like( - $state, - { - runners => { - one => {runner_id => 'one'}, # The runner added for our transacton - }, - }, - "Got initial state" - ); - - # Remove the local data (not stored) - my $local = delete $state->{local}; - like( - $local, - { - lock => FDNE, # The lock should not be present anymore (it is weakened inside the transaction, gone after) - write => T, # This was a write transaction - }, - "Local data is as expected", - ); - - my $stored = Test2::Harness::Util::File::JSON->new(name => $one->state_file)->read; - is($state, $stored, "state and stored match"); -}; - -subtest transaction => sub { - my $one = inst(runner_id => 'one'); - - my $end_state = $one->transaction( - w => sub { - my ($the_one, $state, @args) = @_; - - ref_is($the_one, $one, "Got the instance first"); - ref_ok($state, 'HASH', "got a hash"); - is(\@args, [qw/arg1 arg2/], "Got additional args"); - - my $local_check = { - lock => T(), - write => T(), - mode => 'w', - stack => [ - {cb => T(), args => ['arg1', 'arg2']}, - ] - }; - - is($state->{local}, $local_check, "Got accurate state"); - - subtest nested_transaction => sub { - $one->transaction( - 'r' => sub { - my ($also_the_one, $also_state) = @_; - - ref_is($also_the_one, $one, "got the same instance"); - ref_is($also_state, $state, "Got the same state object"); - - is( - $state->{local}, - { - lock => T(), - write => F(), - mode => 'r', - stack => [ - {cb => T(), args => ['arg1', 'arg2']}, - {cb => T(), args => []}, - ] - }, - "State temporarily modified" - ); - }, - ); - }; - - is($one->transaction(), $state, "transaction with no callback returns state"); - - is($state->{local}, $local_check, "State restored"); - - return $state; - }, - 'arg1', - 'arg2' - ); - - like( - $end_state, - { - local => {lock => FDNE}, # Lock released - runners => { - one => { # Added runner - user => $ENV{USER}, - seen => T(), - added => T(), - runner_id => 'one', - }, - }, - }, - "Got correct end state" - ); - - my $two = inst(runner_id => 'two', state_file => $one->{state_file}); - my $state = $two->update_registration; - - ok($state->{runners}->{two}, "Got registration"); - - $two->transaction( - rw => sub { - my ($me, $state) = @_; - $state->{runners}->{two}->{remove} = 1; - } - ); - - $state = $one->transaction( - ro => sub { - my ($me, $state) = @_; - ok(!$state->{runners}->{two}, "Two is not registered anymore"); - } - ); - - like( - dies { $two->transaction('rw') }, - qr/Shared slot registration expired/, - "Cannot proceed if our registration expired", - ); - - my $three = inst(runner_id => 'three', state_file => $one->{state_file}); - $state = $three->update_registration; - - ok($state->{runners}->{three}, "Got registration"); - - $one->transaction( - rw => sub { - my ($me, $state) = @_; - $state->{runners}->{three}->{seen} = 1; # Very long time ago. - } - ); - - # Make sure RO mode is aware, even though it does not write the update - $state = $one->transaction( - ro => sub { - my ($me, $state) = @_; - ok(!$state->{runners}->{three}, "Three is not registered anymore (timed out)"); - ok(!$state->{runners}->{two}, "Two is not registered anymore"); - } - ); - - $state = $one->transaction( - rw => sub { - my ($me, $state) = @_; - ok(!$state->{runners}->{three}, "Three is not registered anymore (timed out)"); - ok(!$state->{runners}->{two}, "Two is not registered anymore"); - return $state; - } - ); - - delete $state->{local}; - - my $stored = Test2::Harness::Util::File::JSON->new(name => $one->state_file)->read; - is($state, $stored, "state and stored match"); -}; - -sub consistent_state { - my ($insts, $state_check) = @_; - - my $ctx = context(); - - my $state; - subtest "consistent state" => sub { - my $base = $state = shift(@$insts); - my $state = $base->state; - - my $idx = 1; - while (my $i = shift @$insts) { - my $st2 = $i->state; - is($st2, $state, "state [" . $idx++ . "] matches state [0]"); - } - - use Data::Dumper; - is($state, $state_check, "State matches expectations", Dumper($state)) if $state_check; - }; - - $ctx->release; - - return $state; -} - -subtest registration => sub { - my $one = inst(runner_id => 'one'); - my $two = inst(runner_id => 'two', state_file => $one->{state_file}); - my $three = inst(runner_id => 'three', state_file => $one->{state_file}); - - $one->update_registration; - consistent_state( - [$one, $two, $three], - hash { - field runners => { - one => T(), - }; - etc; - }, - ); - - $two->update_registration; - consistent_state( - [$one, $two, $three], - hash { - field runners => { - one => T(), - two => T(), - }; - etc; - }, - ); - - $three->update_registration; - consistent_state( - [$one, $two, $three], - hash { - field runners => { - one => T(), - two => T(), - three => T(), - }; - etc; - }, - ); - - $two->remove_registration; - consistent_state( - [$one, $two, $three], - hash { - field runners => { - one => T(), - two => DNE(), - three => T(), - }; - etc; - }, - ); - - # Emulate 'three' timing out. - my $file = Test2::Harness::Util::File::JSON->new(name => $one->{state_file}); - my $data = $file->read; - $data->{runners}->{three}->{seen} -= 100 + $one->TIMEOUT; - $file->write($data); - - consistent_state( - [$one, $two, $three], - hash { - field runners => { - one => T(), - two => DNE(), - three => DNE(), - }; - etc; - }, - ); - - like( - dies { $three->update_registration }, - qr/Shared slot registration expired/, - "Cannot write after timing out" - ); -}; - -subtest _entry_expired => sub { - my $one = inst(runner_id => 'one'); - - ok($one->_entry_expired(undef), "Invalid entry is expired"); - ok($one->_entry_expired({remove => 1}), "Entry to be removed is expired"); - ok($one->_entry_expired({}), "no 'seen' field expired"); - - ok(!$one->_entry_expired({seen => time}), "Recently seen, not expired"); - - ok($one->_entry_expired({seen => (time - (10 + $one->TIMEOUT))}), "Old is expired"); -}; - -subtest runner_todo => sub { - my $one = inst(runner_id => 'one'); - - my $entry = {}; - is($one->_runner_todo($entry), undef, "Nothing to do"); - is($one->_runner_todo($entry, 'j1'), undef, "Nothing to do"); - - is($one->_runner_todo($entry, j1 => 2), 2, "Got job count"); - is($entry->{todo}, 2, "todo is set"); - - is($one->_runner_todo($entry, j2 => 3), 3, "Got job count"); - is($entry->{todo}, 5, "todo is set"); - - is($one->_runner_todo($entry, j3 => 1), 1, "Got job count"); - is($entry->{todo}, 6, "todo is set"); - - is($one->_runner_todo($entry, 'j2'), 3, "Got job count"); - is($entry->{todo}, 6, "todo is set"); - - is($one->_runner_todo($entry, j2 => -1), 3, "Got job count"); - is($entry->{todo}, 3, "todo is set"); -}; - -subtest _runner_calcs => sub { - my $one = inst(runner_id => 'one'); - - my $r = { - _calc_cache => "cache!", - max_slots => 100, - assigned => {1 => {count => 1}, 2 => {count => 2}}, - allocated => 3, - todo => 101, - }; - - is($one->_runner_calcs($r), "cache!", "Get cache if it is present"); - - delete $r->{_calc_cache}; - - is( - $one->_runner_calcs($r), - { - max => 9, # Use the global max as runner max is too high - assigned => 3, - active => 6, # Assigned + Allocated - total => 107, # Active + TODO - wants => 9, # We have more tests than slots, so we want the max - }, - "Calculated data", - ); - ok($r->{_calc_cache}, "Have a cache"); - is($one->_runner_calcs($r), $r->{_calc_cache}, "Result matches cache"); - $r->{_calc_cache}->{xxx} = 'added'; - is($one->_runner_calcs($r), $r->{_calc_cache}, "Result matches cache"); - is($one->_runner_calcs($r)->{xxx}, 'added', "Extra cache key found"); - - $r = { - max_slots => 5, - assigned => {1 => {count => 2}, 2 => {count => 2}}, - allocated => 0, - todo => 101, - }; - is( - $one->_runner_calcs($r), - { - max => 5, # Use our max, less than the global - assigned => 4, - active => 4, # Assigned + Allocated - total => 105, # Active + TODO - wants => 5, # We want our max - }, - "Calculated data", - ); - - $r = { - assigned => {1 => {count => 5}, 2 => {count => 5}}, - allocated => 2, - todo => 101, - }; - is( - $one->_runner_calcs($r), - { - max => 9, - assigned => 10, - active => 12, # Assigned + Allocated - total => 113, # Active + TODO - wants => 12, # We want what we are already using, even though it is higher than max. - }, - "Calculated data", - ); -}; - -subtest allocate_slots => sub { - my $one = inst(runner_id => 'one'); - - like(dies { $one->allocate_slots(todo => 1) }, qr/'con' is required/, "con must be specified"); - - $one->{max_slots_per_job} = 10; $one->{my_max_slots_per_job} = 11; $one->{max_slots} = 11; - like( - dies { $one->allocate_slots(con => [11, 11], todo => 100) }, - qr/Slot request exceeds max slots per job \(11 vs \(10 || 11 || 11\)\)/, - "Cannot exceed slot limits A" - ); - - $one->{max_slots_per_job} = 11; $one->{my_max_slots_per_job} = 10; $one->{max_slots} = 11; - like( - dies { $one->allocate_slots(con => [11, 11], todo => 100) }, - qr/Slot request exceeds max slots per job \(11 vs \(11 || 10 || 11\)\)/, - "Cannot exceed slot limits B" - ); - - $one->{max_slots_per_job} = 11; $one->{my_max_slots_per_job} = 11; $one->{max_slots} = 10; - like( - dies { $one->allocate_slots(con => [11, 11], todo => 100) }, - qr/Slot request exceeds max slots per job \(11 vs \(11 || 11 || 10\)\)/, - "Cannot exceed slot limits C" - ); - - $one->transaction(rw => sub { - my ($self, $state) = @_; - - # Make sure we have an allocation so we do not trigger a redistribute. - $state->{runners}->{one}->{allocated} = 5; - $state->{runners}->{one}->{allotment} = 2; - - # Do calcs and cache them so we can verify they get cleared. - my $calcs = $self->_runner_calcs($state->{runners}->{one}); - $calcs->{CACHED} = 1; - }); - - ok($one->state->{runners}->{one}->{_calc_cache}->{CACHED}, "runner calc cache is as expected", $one->state->{runners}->{one}->{_calc_cache}); - is($one->state->{runners}->{one}->{allocated}, 5, "Allocation is 5"); - is($one->allocate_slots(con => [4, 4], job_id => '123'), 4, "We got 4 slots!"); - ok(!$one->state->{runners}->{one}->{_calc_cache}->{CACHED}, "Allocating slots reset runner calc cache", $one->state->{runners}->{one}->{_calc_cache}); - is($one->state->{runners}->{one}->{allocated}, 4, "Allocation updated to 4"); -}; - -done_testing; - -__END__ - -TODO do more testing on this - -sub _allocate_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - delete $entry->{_calc_cache}; - - my $count = $params{count}; - my $job_id = $params{job_id}; - $self->_runner_todo($entry, $job_id => $count); - - my $allocated = $entry->{allocated}; - - # We have what we need already allocated - return $entry->{allocated} = $count - if $count <= $allocated; - - # Our allocation, if any, is not big enough, free it so we do not have a - # deadlock with all runner holding an insufficient allocation. - $allocated = $entry->{allocated} = 0; - - my $calcs = $self->_runner_calcs($entry); - - for (0 .. 1) { - $self->_redistribute($state) if $_; # Only run on second loop - - # Cannot do anything if we have no allotment or no available slots. - # This will go to the next loop for a redistribution, or end the loop. - my $allotment = $entry->{allotment} or next; - my $available = $allotment - $calcs->{assigned} or next; - - # If our allotment is lower than the count we may end up never getting - # enough, so we forcefully reduce the count. - # We do this for busy systems where the pool is too small to meet the - # request. But we do not reduce the count to the available level, - # availability can change to match the allotment. - my $c = min($allotment, $count); - - next unless $available >= $c; - return $entry->{allocated} = $c; - } - - return 0; -} - -sub assign_slots { - my $self = shift; - my (%params) = @_; - - my $job = $params{job} or croak "'job' is required"; - - return $self->transaction(rw => '_assign_slots', job => $job); -} - -sub _assign_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - delete $entry->{_calc_cache}; - - my $job = $params{job}; - my $job_id = $job->{job_id}; - my $allocated = $entry->{allocated}; - - my $count = $self->_runner_todo($entry, $job_id => -1); - - $job->{count} = $count; - $job->{started} = time; - - $entry->{allocated} = 0; - - $entry->{assigned}->{$job->{job_id}} = $job; - - return $job; -} - -sub release_slots { - my $self = shift; - my (%params) = @_; - - my $job_id = $params{job_id} or croak "'job_id' is required"; - - return $self->transaction(rw => '_release_slots', job_id => $job_id); -} - -sub _release_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - - my $job_id = $params{job_id}; - - delete $entry->{assigned}->{$job_id}; - delete $entry->{_calc_cache}; - - $self->_runner_todo($entry, $job_id => -1); - - # Reduce our allotment if it makes sense to do so. - my $calcs = $self->_runner_calcs($entry); - $entry->{allotment} = $calcs->{total} if $entry->{allotment} > $calcs->{total}; -} - -sub _redistribute { - my $self = shift; - my ($state) = @_; - - my $max_run = $self->{+MAX_SLOTS_PER_RUN}; - - my $wanted = 0; - for my $runner (values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - $runner->{allotment} = $calcs->{wants}; - $wanted += $calcs->{wants}; - } - - # Everyone gets what they want! - my $max = $self->{+MAX_SLOTS}; - return if $wanted <= $max; - - my $meth = $self->{+ALGORITHM}; - - return $self->$meth($state); -} - -sub _redistribute_first { - my $self = shift; - my ($state) = @_; - - my $min = $self->{+MIN_SLOTS_PER_RUN}; - my $max = $self->{+MAX_SLOTS}; - - my $c = 0; - for my $runner (sort { $a->{added} <=> $b->{added} } values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - my $wants = $calcs->{wants}; - - if ($max >= $wants) { - $runner->{allotment} = $wants; - } - else { - $runner->{allotment} = max($max, $min, 0); - } - - $max -= $runner->{allotment}; - - $c++; - } - - return; -} - -sub _redistribute_fair { - my $self = shift; - my ($state) = @_; - - my $runs = scalar keys %{$state->{+RUNNERS}}; - - # Avoid a divide by 0 below. - return unless $runs; - - my $total = $self->{+MAX_SLOTS}; - my $min = $self->{+MIN_SLOTS_PER_RUN}; - - my $used = 0; - for my $runner (values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - - # We never want less than the 'active' number - my $set = $calcs->{active}; - - # If min is greater than the active number and there are todo tests, we - # use the min instead. - $set = $min if $set < $min && $runner->todo; - - $runner->{allotment} = $set; - $used += $set; - } - - my $free = $total - $used; - return unless $free >= 1; - - # Is there a more efficient way to do this? Yikes! - my @runners = values %{$state->{+RUNNERS}}; - while ($free > 0) { - @runners = sort { $a->{allotment} <=> $b->{allotment} || $a->{added} <=> $b->{added} } - grep { my $c = $self->_runner_calcs($_); $c->{wants} > $_->{allotment} } - @runners; - - $free--; - $runners[0]->{allotment}++; - } - - return; -} - - diff --git a/t/unit/Test2/Harness/Settings.t b/t/unit/Test2/Harness/Settings.t deleted file mode 100644 index 7e8948a32..000000000 --- a/t/unit/Test2/Harness/Settings.t +++ /dev/null @@ -1,64 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Settings'; -use File::Temp qw/tempfile/; -use Test2::Harness::Util::JSON qw/encode_json/; - -my $one = $CLASS->new(); -isa_ok($one, [$CLASS], "Created an instance"); - -ok(!$one->check_prefix('foo'), "foo is not defined"); -like(dies { $one->foo }, qr/The 'foo' prefix is not defined/, "Cannot call foo if it is not defined"); -like(dies { $one->prefix('foo') }, qr/The 'foo' prefix is not defined/, "Cannot call prefix(foo) if it is not defined"); - -$one->define_prefix('foo'); -isa_ok($one->foo, ['Test2::Harness::Settings::Prefix'], "Defined the prefix"); -ok($one->check_prefix('foo'), "foo is now defined"); -ok($one->foo, "Can call foo if it is defined"); -ok($one->prefix('foo'), "Can call prefix(foo) if it is defined"); - -is($one->TO_JSON, {foo => exact_ref($one->foo)}, "TO_JSON"); - -like(dies { $CLASS->foo }, qr/Method foo\(\) must be called on a blessed instance/, "Need a blessed instance"); -like(dies { $one->foo(1) }, qr/Too many arguments for foo\(\)/, "No args"); - -{ - $INC{'XXX.pm'} = __FILE__; - package XXX; - sub new { shift; bless {@_}, 'XXX' }; -} - -$one->foo->vivify_field('xxx'); -$one->foo->field(xxx => 'yyy'); - -my $thing = $one->build('foo', 'XXX', a => 'b'); -isa_ok($thing, ['XXX'], "Got a blessed instance of XXX"); -is( - $thing, - { - a => 'b', - xxx => 'yyy', - }, - "Instance is composed as expected" -); - -my ($fh, $name) = tempfile(UNLINK => 1); -print $fh encode_json($one); -close($fh); - -my $two = $CLASS->new($name); -isa_ok($two, [$CLASS], "Correct class"); -is($two, $one, "Serialized and deserialized round trip"); -ref_is_not($two, $one, "2 different refs"); - -like( - dies { $CLASS->new(foo => []) }, - qr/All prefixes must be defined as hashes/, - "Prefixes must be hashes" -); - -like( - dies { $CLASS->new(foo => bless({}, 'XXX')) }, - qr/All prefixes must contain instances of Test2::Harness::Settings::Prefix/, - "Blessed Prefixes must be prefixes" -); - -done_testing; diff --git a/t/unit/Test2/Harness/Settings/Prefix.t b/t/unit/Test2/Harness/Settings/Prefix.t deleted file mode 100644 index 10902e20a..000000000 --- a/t/unit/Test2/Harness/Settings/Prefix.t +++ /dev/null @@ -1,66 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Settings::Prefix'; - -my $one = $CLASS->new(); -isa_ok($one, [$CLASS], "Created an instance"); -ref_ok($one, 'REF', "Hash is slightly obscured by an extra deref"); - -like( - dies { $one->foo }, - qr/The 'foo' field does not exist/, - "Must use a valid field" -); - -ref_ok($one->vivify_field('foo'), 'SCALAR', "vivify returns a ref"); -is($one->foo, undef, "Not set yet"); - -$one->foo('bar'); -is($one->foo, 'bar', "Set value"); - -if ("$]" >= 5.016) { - $one->foo = 'baz'; - is($one->foo, 'baz', "Set via lvalue"); -} -else { - $one->field(foo => 'baz'); -} - -is($one->field('foo'), 'baz', "Got via field"); -$one->field('foo', 'xxx'); -is($one->field('foo'), 'xxx', "Set via field"); - -like( - dies { $one->field('foo', 'bar', 'baz') }, - qr/Too many arguments for field\(\)/, - "Field only takes 2 args" -); - -like( - dies { $CLASS->foo }, - qr/Method foo\(\) must be called on a blessed instance/, - "Autload does not work on class" -); - -is( - $one->TO_JSON, - { foo => 'xxx' }, - "JSON structure" -); - -{ - $INC{'TheThing.pm'} = 1; - package TheThing; - use Test2::Harness::Util::HashBase qw/foo bar/; -} - -my $res = $one->build('TheThing', bar => 'yyy'); -isa_ok($res, ['TheThing'], "Created an instance"); -is( - $res, - { - foo => 'xxx', - bar => 'yyy', - }, - "Created with args" -); - -done_testing; diff --git a/t/unit/Test2/Harness/TestFile.t b/t/unit/Test2/Harness/TestFile.t deleted file mode 100644 index f0daa2d85..000000000 --- a/t/unit/Test2/Harness/TestFile.t +++ /dev/null @@ -1,691 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::TestFile'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -use Test2::Tools::GenTemp qw/gen_temp/; - -my $tmp = gen_temp( - long => "#!/usr/bin/perl\n\nuse strict;\n use warnings\n\n# HARNESS-CAT-LONG\n# HARNESS-NO-TIMEOUT\n# HARNESS-USE-ISOLATION\nfoo\n# HARNESS-NO-SEE\n", - med1 => "# HARNESS-NO-PRELOAD\n", - med2 => "#HARNESS-NO-FORK\n", - all => "#HARNESS-NO-TIMEOUT\n# HARNESS-NO-STREAM\n# HARNESS-NO-FORK\n# HARNESS-NO-PRELOAD\n# HARNESS-USE-ISOLATION\n", - notime => "#HARNESS-NO-TIMEOUT\n", - warn => "#!/usr/bin/perl -w\n", - taint => "#!/usr/bin/env perl -t -w\n", - foo => "#HARNESS-CATEGORY-FOO\n#HARNESS-STAGE-FoO", - meta => "#HARNESS-META-mykey-myval\n# HARNESS-META-otherkey-otherval\n# HARNESS-META mykey my-val2\n# HARNESS-META slack #my-val # comment after harness statement\n", - - package => "package Foo::Bar::Baz;\n# HARNESS-NO-PRELOAD\n", - - timeout => "# HARNESS-TIMEOUT-EVENT 90\n# HARNESS-TIMEOUT-POSTEXIT 85\n", - timeout2 => "# HARNESS-TIMEOUT-EVENT-90\n# HARNESS-TIMEOUT-POST-EXIT 85\n", - badtimeout => "# HARNESS-TIMEOUT-EVENTX 90\n# HARNESS-TIMEOUT-POSTEXITX 85\n", - - conflicts1 => "# HARNESS-CONFLICTS PASSWD\n", - conflicts2 => "# HARNESS-CONFLICTS PASSWD DAEMON\n", - conflicts3 => "# HARNESS-CONFLICTS PASSWD\n# HARNESS-CONFLICTS DAEMON # Nothing to see here\n", - conflicts4 => "# HARNESS-CONFLICTS PASSWD DAEMON\n# HARNESS-CONFLICTS PASSWD\n# HARNESS-CONFLICTS PASSWD\n# HARNESS-CONFLICTS PASSWD DAEMON\n", - - extra_comments => "#!/usr/bin/perl\n\nuse strict;\n# comment here\n use warnings\n\n# copyright Dewey Cheatem and Howe\n# HARNESS-CAT-LONG\n# HARNESS-NO-TIMEOUT\n# HARNESS-USE-ISOLATION\n", - - smoke1 => "#HARNESS-SMOKE\n", - smoke2 => "#HARNESS-YES-SMOKE\n", - - retry => "#HARNESS-RETRY\n", # mean retry once => --retry similar to --retry=1 - retry5 => "#HARNESS-RETRY 5\n", - retry_iso => "#HARNESS-RETRY-ISO\n", - retry_iso3 => "#HARNESS-RETRY-ISO 3\n", - no_retry => "#HARNESS-NO-RETRY\n", - - not_perl => "#!/usr/bin/bash\n", - not_env_perl => "#!/usr/bin/env bash\n", - binary => "\0\a\cX\e\n\cR", -); - -subtest timeouts => sub { - my $one = $CLASS->new(file => File::Spec->catfile($tmp, 'timeout')); - is($one->event_timeout, 90, "set event timeout"); - is($one->post_exit_timeout, 85, "set event timeout"); - - my $task = $one->queue_item(42); - is($task->{event_timeout}, 90, "event timeout made it to task"); - is($task->{post_exit_timeout}, 85, "post-exit timeout made it to task"); - - my $two = $CLASS->new(file => File::Spec->catfile($tmp, 'timeout2')); - is($two->event_timeout, 90, "set event timeout"); - is($two->post_exit_timeout, 85, "set event timeout"); - - my $bad = $CLASS->new(file => File::Spec->catfile($tmp, 'badtimeout')); - is( - warnings { $bad->headers }, - [ - "'EVENTX' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at " . $bad->file . " line 1.\n", - "'POSTEXITX' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at " . $bad->file . " line 2.\n", - ], - "Got warnings" - ); -}; - -subtest invalid => sub { - like( - dies { $CLASS->new(file => File::Spec->catfile($tmp, 'invalid')) }, - qr/^Invalid test file/, - "Need a valid test file" - ); -}; - -subtest meta => sub { - my $foo = $CLASS->new(file => File::Spec->catfile($tmp, 'meta')); - - is([$foo->meta], [], "No key returns empty list"); - is([$foo->meta('foo')], [], "Empty key returns empty list"); - is([$foo->meta('mykey')], [qw/myval my-val2/], "Got both values for the 'mykey' key"); - is([$foo->meta('otherkey')], ['otherval'], "Got other key"); - is([$foo->meta('slack')], ['#my-val'], "Got hyphenated key"); -}; - -subtest foo => sub { - my $foo = $CLASS->new(file => File::Spec->catfile($tmp, 'foo')); - is($foo->check_category, 'foo', "Category is foo"); - is($foo->check_stage, 'FoO', "Stage is FoO, case-sensitive"); -}; - -subtest package => sub { - my $one = $CLASS->new(file => File::Spec->catfile($tmp, 'package')); - is($one->queue_item(42)->{use_preload}, 0, "No preload"); -}; - -subtest taint => sub { - my $taint = $CLASS->new(file => File::Spec->catfile($tmp, 'taint'), queue_args => [via => ['xxx']]); - - is($taint->switches, ['-t', '-w'], "No SHBANG switches"); - is($taint->shbang, {switches => ['-t', '-w'], line => "#!/usr/bin/env perl -t -w"}, "Parsed shbang"); - - is( - $taint->queue_item(42), - { - category => 'general', - duration => 'medium', - stage => undef, - file => $taint->file, - rel_file => $taint->relative, - job_name => 42, - job_id => T(), - stamp => T(), - switches => ['-t', '-w'], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - via => ['xxx'], - rank => T(), - run_id => FDNE(), - }, - "Got queue item data", - ); -}; - -subtest warn => sub { - my $warn = $CLASS->new(file => File::Spec->catfile($tmp, 'warn')); - - is($warn->switches, ['-w'], "got SHBANG switches"); - is($warn->shbang, {switches => ['-w'], line => "#!/usr/bin/perl -w"}, "Parsed shbang"); - - is( - $warn->queue_item(42), - { - category => 'general', - duration => 'medium', - stage => undef, - file => $warn->file, - rel_file => $warn->relative, - job_name => 42, - job_id => T(), - stamp => T(), - rank => T(), - switches => ['-w'], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - run_id => FDNE(), - }, - "Got queue item data", - ); -}; - -subtest notime => sub { - my $notime = $CLASS->new(file => File::Spec->catfile($tmp, 'notime')); - - is($notime->check_feature('timeout'), 0, "Timeouts turned off"); - is($notime->check_feature('timeout', 1), 0, "Timeouts turned off with default 1"); - - is($notime->check_category, 'general', "Category is general"); - is($notime->check_duration, 'long', "Duration is long"); - - is($notime->switches, [], "No SHBANG switches"); - is($notime->shbang, {}, "No shbang"); - - is( - $notime->queue_item(42), - { - category => 'general', - duration => 'long', - stage => undef, - file => $notime->file, - rel_file => $notime->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 0, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - run_id => FDNE(), - }, - "Got queue item data", - ); -}; - -subtest all => sub { - my $all = $CLASS->new(file => File::Spec->catfile($tmp, 'all')); - - is($all->check_feature('timeout'), 0, "Timeouts turned off"); - is($all->check_feature('timeout', 1), 0, "Timeouts turned off with default 1"); - - is($all->check_feature('fork'), 0, "Forking is off"); - is($all->check_feature('fork', 1), 0, "Checking fork with different default"); - - is($all->check_feature('preload'), 0, "Preload is off"); - is($all->check_feature('preload', 1), 0, "Checking preload with different default"); - - is($all->check_feature('isolation'), 1, "No isolation"); - is($all->check_feature('isolation', 0), 1, "Use isolation with a default of false"); - - is($all->check_feature('stream'), 0, "Use stream"); - is($all->check_feature('stream', 1), 0, "no stream with a default of true"); - - is($all->check_category, 'isolation', "Category is isolation"); - - is($all->switches, [], "No SHBANG switches"); - is($all->shbang, {}, "No shbang"); - - is( - $all->queue_item(42), - { - category => 'isolation', - duration => 'long', - stage => undef, - file => $all->file, - rel_file => $all->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 0, - use_preload => 0, - use_stream => 0, - io_events => 1, - use_timeout => 0, - smoke => 0, - conflicts => [], - binary => 0, - non_perl => 0, - run_id => FDNE(), - }, - "Got queue item data", - ); -}; - -subtest med2 => sub { - my $med2 = $CLASS->new(file => File::Spec->catfile($tmp, 'med2')); - - is($med2->check_feature('timeout'), 1, "Timeouts turned on"); - is($med2->check_feature('timeout', 0), 0, "Timeouts turned off with default 0"); - - is($med2->check_feature('fork'), 0, "Forking is off"); - is($med2->check_feature('fork', 1), 0, "Checking fork with different default"); - - is($med2->check_feature('preload'), 1, "Preload is on"); - is($med2->check_feature('preload', 0), 0, "Checking preload with different default"); - - is($med2->check_feature('isolation'), 0, "No isolation"); - is($med2->check_feature('isolation', 1), 1, "Use isolation with a default of true"); - - is($med2->check_feature('stream'), 1, "Use stream"); - is($med2->check_feature('stream', 0), 0, "no stream with a default of false"); - - is($med2->check_category, 'general', "Category is general"); - is($med2->check_duration, 'medium', "duration is medium"); - - is($med2->switches, [], "No SHBANG switches"); - is($med2->shbang, {}, "No shbang"); - - is( - $med2->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => $med2->file, - rel_file => $med2->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 0, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - }, - "Got queue item data", - ); -}; - -subtest med1 => sub { - my $med1 = $CLASS->new(file => File::Spec->catfile($tmp, 'med1')); - - is($med1->check_feature('timeout'), 1, "Timeouts turned on"); - is($med1->check_feature('timeout', 0), 0, "Timeouts turned off with default 0"); - - is($med1->check_feature('fork'), 1, "Forking is ok"); - is($med1->check_feature('fork', 0), 0, "Checking fork with different default"); - - is($med1->check_feature('preload'), 0, "Preload is off"); - is($med1->check_feature('preload', 1), 0, "Checking preload with different default"); - - is($med1->check_feature('isolation'), 0, "No isolation"); - is($med1->check_feature('isolation', 1), 1, "Use isolation with a default of true"); - - is($med1->check_feature('stream'), 1, "Use stream"); - is($med1->check_feature('stream', 0), 0, "no stream with a default of false"); - - is($med1->check_category, 'general', "Category is general"); - is($med1->check_duration, 'medium', "duration is medium"); - - is($med1->switches, [], "No SHBANG switches"); - is($med1->shbang, {}, "No shbang"); - - is( - $med1->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => $med1->file, - rel_file => $med1->relative, - job_name => 42, - stamp => T(), - rank => T(), - job_id => T(), - switches => [], - use_fork => 1, - use_preload => 0, - use_stream => 1, - io_events => 1, - use_timeout => 1, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - }, - "Got queue item data", - ); -}; - -subtest long => sub { - my $long = $CLASS->new(file => File::Spec->catfile($tmp, 'long')); - - is($long->check_feature('timeout'), 0, "Timeouts turned off"); - is($long->check_feature('timeout', 1), 0, "Timeouts turned off even with default 1"); - - is($long->check_feature('fork'), 1, "Forking is ok"); - is($long->check_feature('fork', 0), 0, "Checking fork with different default"); - - is($long->check_feature('preload'), 1, "Preload is ok"); - is($long->check_feature('preload', 0), 0, "Checking preload with different default"); - - is($long->check_feature('isolation'), 1, "Use isolation"); - is($long->check_feature('isolation', 0), 1, "Use isolation even with a default of false"); - - is($long->check_feature('stream'), 1, "Use stream"); - is($long->check_feature('stream', 0), 0, "no stream with a default of false"); - - is($long->check_category, 'isolation', "Category is isolation"); - is($long->check_duration, 'long', "duration is long"); - - ok(!exists $long->headers->{SEE}, "Did not see directive after code line"); - - is($long->switches, [], "No SHBANG switches"); - is($long->shbang, {switches => [], line => "#!/usr/bin/perl"}, "got shbang"); - - is( - $long->queue_item(42), - { - run_id => FDNE(), - category => 'isolation', - duration => 'long', - stage => undef, - file => $long->file, - rel_file => $long->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 0, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - }, - "Got queue item data", - ); -}; - -subtest extra_comments => sub { - my $long = $CLASS->new(file => File::Spec->catfile($tmp, 'extra_comments')); - - is($long->check_feature('timeout'), 0, "Timeouts turned off"); - is($long->check_feature('timeout', 1), 0, "Timeouts turned off even with default 1"); - - is($long->check_feature('fork'), 1, "Forking is ok"); - is($long->check_feature('fork', 0), 0, "Checking fork with different default"); - - is($long->check_feature('preload'), 1, "Preload is ok"); - is($long->check_feature('preload', 0), 0, "Checking preload with different default"); - - is($long->check_feature('isolation'), 1, "Use isolation"); - is($long->check_feature('isolation', 0), 1, "Use isolation even with a default of false"); - - is($long->check_feature('stream'), 1, "Use stream"); - is($long->check_feature('stream', 0), 0, "no stream with a default of false"); - - is($long->check_category, 'isolation', "Category is isolation"); - is($long->check_duration, 'long', "Duration is long"); - - is($long->switches, [], "No SHBANG switches"); - is($long->shbang, {switches => [], line => "#!/usr/bin/perl"}, "got shbang"); - - is( - $long->queue_item(42), - { - run_id => FDNE(), - category => 'isolation', - duration => 'long', - stage => undef, - file => $long->file, - rel_file => $long->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 0, - binary => 0, - non_perl => 0, - smoke => 0, - conflicts => [], - }, - "Got queue item data", - ); -}; - -subtest conflicts => sub { - my $parsed_file = $CLASS->new(file => File::Spec->catfile($tmp, 'conflicts1')); - is($parsed_file->conflicts_list, ['passwd'], "1 conflict line is reflected as an array"); - - $parsed_file = $CLASS->new(file => File::Spec->catfile($tmp, 'conflicts2')); - is([sort @{$parsed_file->conflicts_list}], ['daemon', 'passwd'], "1 conflict line with 2 conflict categories"); - - $parsed_file = $CLASS->new(file => File::Spec->catfile($tmp, 'conflicts3')); - is([sort @{$parsed_file->conflicts_list}], ['daemon', 'passwd'], "2 conflict lines with some comments on one of them"); - - $parsed_file = $CLASS->new(file => File::Spec->catfile($tmp, 'conflicts4')); - is([sort @{$parsed_file->conflicts_list}], ['daemon', 'passwd'], "Duplicate conflict lines only lead to 2 conflict items."); - -}; - -subtest binary => sub { - my $path = File::Spec->catfile($tmp, 'binary'); - ok(-B $path, "File is binary"); - - like( - dies { my $binary = $CLASS->new(file => $path); $binary->shbang }, - qr{Cannot run binary test file '[^']*\Q$path\E': file is not executable\.}, - "File must be executable", - ); - - my $control = mock $CLASS => ( - override => [ - is_executable => sub { 1 }, - ], - ); - - my $binary = $CLASS->new(file => $path); - is($binary->switches, [], "No SHBANG switches"); - is($binary->shbang, {}, "No shbang"); - - is( - $binary->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => match qr{\Q$path\E$}, - rel_file => $binary->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - conflicts => [], - binary => 1, - non_perl => 1, - smoke => 0, - }, - "Got queue item data", - ); -}; - -subtest not_perl => sub { - my $path = File::Spec->catfile($tmp, 'not_perl'); - - like( - dies { my $not_perl = $CLASS->new(file => $path); $not_perl->shbang }, - qr{Cannot run non-perl test file '[^']*\Q$path\E': file is not executable\.}, - "File must be executable", - ); - - my $control = mock $CLASS => ( - override => [ - is_executable => sub { 1 }, - ], - ); - - my $not_perl = $CLASS->new(file => File::Spec->catfile($tmp, 'not_perl')); - - is($not_perl->switches, [], "No SHBANG switches"); - is($not_perl->shbang, {line => "#!/usr/bin/bash", non_perl => 1}, "Non-perl shbang"); - - is( - $not_perl->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => match qr{\Q$path\E$}, - rel_file => $not_perl->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - conflicts => [], - binary => 0, - non_perl => 1, - smoke => 0, - }, - "Got queue item data", - ); -}; - - -subtest not_env_perl => sub { - my $path = File::Spec->catfile($tmp, 'not_env_perl'); - - like( - dies { my $not_env_perl = $CLASS->new(file => $path); $not_env_perl->shbang }, - qr{Cannot run non-perl test file '[^']*\Q$path\E': file is not executable\.}, - "File must be executable", - ); - - my $control = mock $CLASS => ( - override => [ - is_executable => sub { 1 }, - ], - ); - - my $not_env_perl = $CLASS->new(file => File::Spec->catfile($tmp, 'not_env_perl')); - - is($not_env_perl->switches, [], "No SHBANG switches"); - is($not_env_perl->shbang, {line => "#!/usr/bin/env bash", non_perl => 1}, "Non-perl shbang"); - - is( - $not_env_perl->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => match qr{\Q$path\E$}, - rel_file => $not_env_perl->relative, - job_name => 42, - job_id => T(), - rank => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - conflicts => [], - smoke => 0, - binary => 0, - non_perl => 1, - }, - "Got queue item data", - ); -}; - -subtest smoke => sub { - my $path = File::Spec->catfile($tmp, 'smoke1'); - my $smoke1 = $CLASS->new(file => $path); - is($smoke1->check_feature(smoke => 0), 1, "Turned smoke on"); - is( - $smoke1->queue_item(42), - { - run_id => FDNE(), - category => 'general', - duration => 'medium', - stage => undef, - file => match qr{\Q$path\E$}, - rel_file => $smoke1->relative, - job_name => 42, - rank => T(), - job_id => T(), - stamp => T(), - switches => [], - use_fork => 1, - use_preload => 1, - use_stream => 1, - io_events => 1, - use_timeout => 1, - binary => 0, - non_perl => 0, - smoke => 1, - conflicts => [], - }, - "Got queue item data", - ); - - my $smoke2 = $CLASS->new(file => File::Spec->catfile($tmp, 'smoke2')); - is($smoke2->check_feature(smoke => 0), 1, "Turned smoke on"); -}; - -subtest smoke => sub { - my $retry = $CLASS->new(file => File::Spec->catfile($tmp, 'retry')); - my $task = $retry->queue_item(42); - is($task->{retry}, 1, "Enabled retry"); - ok(!exists($task->{retry_isolated}), "not isolated"); - - $retry = $CLASS->new(file => File::Spec->catfile($tmp, 'retry5')); - $task = $retry->queue_item(42); - is($task->{retry}, 5, "Enabled retry, value of 5 results in '6' because of initial try"); - ok(!exists($task->{retry_isolated}), "not isolated"); - - $retry = $CLASS->new(file => File::Spec->catfile($tmp, 'retry_iso')); - $task = $retry->queue_item(42); - is($task->{retry}, 1, "Enabled retry"); - is($task->{retry_isolated}, T(), "isolated retry"); - - $retry = $CLASS->new(file => File::Spec->catfile($tmp, 'retry_iso3')); - $task = $retry->queue_item(42); - is($task->{retry}, 3, "Enabled retry, 1 initital + 3 retries"); - is($task->{retry_isolated}, T(), "isolated retry"); - - $retry = $CLASS->new(file => File::Spec->catfile($tmp, 'no_retry')); - $task = $retry->queue_item(42); - is($task->{retry}, 0, "Retry set to 0"); - ok(!exists($task->{retry_isolated}), "not isolated"); -}; - -done_testing; diff --git a/t/unit/Test2/Harness/Util.t b/t/unit/Test2/Harness/Util.t deleted file mode 100644 index 1fb12b954..000000000 --- a/t/unit/Test2/Harness/Util.t +++ /dev/null @@ -1,91 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util'; -#BEGIN { skip_all 'TODO' } - -use ok $CLASS => ':ALL'; - -use File::Temp qw/tempfile tempdir/; - -imported_ok qw{ - fqmod - maybe_open_file - maybe_read_file - open_file - read_file - write_file - write_file_atomic - - is_same_file -}; - -my ($line) = split /\n/, read_file(__FILE__), 2; -like( - $line, - q{use Test2::Bundle::Extended -target => 'Test2::Harness::Util';}, - "Read file (only checking first line)" -); - -like( - dies { read_file('/fake/file/that/must/not/exist cause I say so') }, - qr{^\QCould not open file '/fake/file/that/must/not/exist cause I say so' (<)\E}, - "Exception thrown when read_file used on non-existing file" -); - -is( - maybe_read_file(__FILE__), - read_file(__FILE__), - "maybe_read_file reads file when it exists" -); - -is( - maybe_read_file('/fake/file/that/must/not/exist cause I say so'), - undef, - "maybe_read_file is undef when file does not exist" -); - -ok(my $fh = open_file(__FILE__), "opened file"); -ok($line = <$fh>, "Can read from file, default mode is 'read'"); - -if (-e '/dev/null') { - ok(my $null = open_file('/dev/null', '>'), "opened /dev/null for writing"); - ok((print $null "xxx\n"), "printed to /dev/null"); - - is( - [write_file('/dev/null', "AAA", "BBB")], - ["AAA", "BBB"], - "wrote and returned content (/dev/null)" - ); -} - -is( - maybe_open_file('/fake/file/that/must/not/exist cause I say so'), - undef, - "maybe_open_file is undef when file does not exist" -); - -is(fqmod('Foo::Bar', 'Baz'), 'Foo::Bar::Baz', "fqmod on postfix"); -is(fqmod('Foo::Bar', 'Baz::Bat'), 'Foo::Bar::Baz::Bat', "fqmod on longer postfix"); -is(fqmod('Foo::Bar', '+Baz'), 'Baz', "fqmod on fq"); -is(fqmod('Foo::Bar', '+Baz::Bat'), 'Baz::Bat', "fqmod on longer fq"); - -my $tmp = tempdir(CLEANUP => 1, TMPDIR => 1); -write_file_atomic(File::Spec->canonpath("$tmp/xxx"), "data"); -$fh = open_file(File::Spec->canonpath("$tmp/xxx"), '<'); -is(<$fh>, "data", "read data from file"); - -open($fh, '>', "$tmp/foo"); -print $fh "\n"; -close($fh); - -open($fh, '>', "$tmp/bar"); -print $fh "\n"; -close($fh); - -link("$tmp/foo", "$tmp/foo2") or die "Could not create link: $!"; -symlink("$tmp/foo", "$tmp/foo3") or die "Could not create link: $!"; - -ok(is_same_file("$tmp/foo", "$tmp/foo"), "Matching filenames"); -ok(is_same_file("$tmp/foo", "$tmp/foo2"), "hard link"); -ok(is_same_file("$tmp/foo", "$tmp/foo3"), "soft link"); -ok(!is_same_file("$tmp/foo", "$tmp/bar"), "Different files"); - -done_testing; diff --git a/t/unit/Test2/Harness/Util/File.t b/t/unit/Test2/Harness/Util/File.t deleted file mode 100644 index 73a15874d..000000000 --- a/t/unit/Test2/Harness/Util/File.t +++ /dev/null @@ -1,102 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -can_ok($CLASS, qw/name done set_done/); - -like( - dies { $CLASS->new }, - qr/'name' is a required attribute/, - "Must provide the 'name' attribute" -); - -open(my $tmpfh, '<', __FILE__) or die "Could not open file: $!"; -my $zed = $CLASS->new(name => __FILE__, fh => $tmpfh); -is($zed->_init_fh, $tmpfh, "saved fh"); -is($zed->fh->blocking, 0, "fh was set to non-blocking"); -$zed = undef; - -my $one = $CLASS->new(name => __FILE__); -my $two = $CLASS->new(name => '/some/super/fake/file/that must not exist'); -ok($one->exists, "This file exists"); -ok(!$two->exists, "The file does not exist"); - -is($one->decode('xxx'), 'xxx', "base class decode does nothing"); -is($one->encode('xxx'), 'xxx', "base class encode does nothing"); - -ok(my $fh = $one->open_file, "opened file (for reading)"); -ok(dies { $two->open_file }, "Cannot open file (for reading)"); - -my ($line) = split /\n/, $one->maybe_read, 2; -like( - $line, - q{use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File';}, - "Can read file (using maybe_read)" -); - -is( - $two->maybe_read, - undef, - "maybe_read returns undef for non-existant file" -); - -($line) = split /\n/, $one->read, 2; -like( - $line, - q{use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File';}, - "Can read file" -); - -ok(dies { $two->read }, "read() dies on missing file"); - -close($fh); - -ok($fh = $one->fh, "Can generate an FH"); -is($one->fh, $fh, "FH is remembered"); -is($fh->blocking, 0, "FH is non-blocking"); - -close($fh); - -is($two->fh, undef, "return undef for missing file"); - -$one->set_done(1); -is($one->done, 1, "can set done"); -$one->reset; -ok(!$one->{_fh}, "removed fh"); -ok(!$one->done, "cleared done flag"); - -$two->reset; -is($two->read_line, undef, "cannot read lines from missing file"); - -is( - $one->read_line, - "use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File';\n", - "Got first line" -); - -while(my $l = $one->read_line) { 1 } - -is($one->read_line, undef, "no line to read yet"); -$one->set_done(1); - -is( - $one->read_line, - "This line MUST be here, and MUST not end with a newline.", - "Got final line with no terminator" -); - -$one->reset; -is( - $one->read_line, - "use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File';\n", - "Got first line again after reset" -); - -#TODO: write (it is atomic) - -done_testing; - -__END__ - -This line MUST be here, and MUST not end with a newline. \ No newline at end of file diff --git a/t/unit/Test2/Harness/Util/File/JSON.t b/t/unit/Test2/Harness/Util/File/JSON.t deleted file mode 100644 index 1a4f2b735..000000000 --- a/t/unit/Test2/Harness/Util/File/JSON.t +++ /dev/null @@ -1,25 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File::JSON'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -isa_ok($CLASS, 'Test2::Harness::Util::File'); - -my $one = $CLASS->new(name => 'fake'); - -is($one->decode('{"a":1}'), {a => 1}, "decode will decode json"); -is($one->encode({}), "{}", "encode will encode json"); - -like( - dies { $one->reset }, - qr/line reading is disabled for json files/, - "Got expected exception for reset()" -); - -like( - dies { $one->read_line }, - qr/line reading is disabled for json files/, - "Got expected exception for read_line()" -); - -done_testing; diff --git a/t/unit/Test2/Harness/Util/File/JSONL.t b/t/unit/Test2/Harness/Util/File/JSONL.t deleted file mode 100644 index c8fa44bc5..000000000 --- a/t/unit/Test2/Harness/Util/File/JSONL.t +++ /dev/null @@ -1,12 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File::JSONL'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -isa_ok($CLASS, 'Test2::Harness::Util::File'); -isa_ok($CLASS, 'Test2::Harness::Util::File::Stream'); - -is($CLASS->decode('{"a":1}'), {a => 1}, "decode will decode json"); -is($CLASS->encode({}), "{}\n", "encode will encode json and append a newline"); - -done_testing; diff --git a/t/unit/Test2/Harness/Util/File/Stream.t b/t/unit/Test2/Harness/Util/File/Stream.t deleted file mode 100644 index 5da1e371c..000000000 --- a/t/unit/Test2/Harness/Util/File/Stream.t +++ /dev/null @@ -1,118 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File::Stream'; -use File::Temp qw/tempfile/; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -my ($wh, $filename) = tempfile("test-$$-XXXXXXXX", TMPDIR => 1); -print $wh ""; -close($wh); - -ok(my $one = $CLASS->new(name => $filename), "New instance"); -$one->write("line1\n"); -$one->write("line2\n"); -$one->write("line3\n"); -$one->write("line"); - -my $fh = $one->open_file('<'); -is( - [<$fh>], - ["line1\n", "line2\n", "line3\n", "line"], - "file written as expected" -); - -is($one->read_line, "line1\n", "got first line"); - -is( - [$one->poll], - [ - "line2\n", - "line3\n", - ], - "Got unseen completed lines, but not incomplete line" -); - -is($one->read_line, undef, "no new lines are ready"); - -is( - [$one->read], - [ - "line1\n", - "line2\n", - "line3\n", - ], - "Read gets lines" -); - -$one->write("4\n"); -$one->write("line5"); - -is( - [$one->read], - [ - "line1\n", - "line2\n", - "line3\n", - "line4\n", - ], - "Read sees the new lines" -); - -is([$one->poll], ["line4\n"], "Poll sees new line after a read"); - -$one->write("\nline6"); - -is($one->read_line, "line5\n", "read_line moves to the next line"); - -is($one->read_line, undef, "no new lines are ready"); -is([$one->poll], [], "no new lines are ready"); - -$one->set_done(1); - -is([$one->poll], ["line6"], "got unterminated line after 'done' was set"); - -$one->reset; -is( - [$one->read], - [ - "line1\n", - "line2\n", - "line3\n", - "line4\n", - "line5\n", - ], - "read all lines but the last unterminated one" -); - -is( - [$one->poll], - [ - "line1\n", - "line2\n", - "line3\n", - "line4\n", - "line5\n", - ], - "poll all lines but the last unterminated one" -); - -$one->set_done(1); -is([$one->poll], ["line6"], "got unterminated line after 'done' was set"); - -$one = undef; - -$one = $CLASS->new(name => $filename); -$one->seek(6); -is( - [$one->poll], - [ - "line2\n", - "line3\n", - "line4\n", - "line5\n", - ], - "Was able to seek past the first item", -); - -unlink($filename); -done_testing; diff --git a/t/unit/Test2/Harness/Util/File/Value.t b/t/unit/Test2/Harness/Util/File/Value.t deleted file mode 100644 index fb0a16368..000000000 --- a/t/unit/Test2/Harness/Util/File/Value.t +++ /dev/null @@ -1,21 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File::Value'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -isa_ok($CLASS, 'Test2::Harness::Util::File'); - -my $one = $CLASS->new(name => __FILE__); - -my $val = $one->read; -chomp(my $no_tail = $val); -is($val, $no_tail, "trailing newline was removed from the value"); - -$val = $one->read_line; -is( - $val, - "use Test2::Bundle::Extended -target => 'Test2::Harness::Util::File::Value';", - "got line, no newline" -); - -done_testing; diff --git a/t/unit/Test2/Harness/Util/JSON.t b/t/unit/Test2/Harness/Util/JSON.t deleted file mode 100644 index 717706495..000000000 --- a/t/unit/Test2/Harness/Util/JSON.t +++ /dev/null @@ -1,31 +0,0 @@ -use Test2::Bundle::Extended -target => 'Test2::Harness::Util::JSON'; -# HARNESS-DURATION-SHORT - -use ok $CLASS; - -imported_ok(qw{ - JSON - encode_json decode_json - encode_pretty_json encode_canon_json -}); - -ok(JSON(), "Have JSON constant"); - -can_ok(JSON(), ['new'], "JSON returns a class (" . JSON() . ")"); - -my $struct = { a => 1, b => 2 }; -for my $encode_name (qw/encode_json encode_pretty_json encode_canon_json/) { - is( - decode_json(__PACKAGE__->can($encode_name)->($struct)), - $struct, - "Round Trip $encode_name+decode" - ); - - is( - decode_json(__PACKAGE__->can($encode_name)->(undef)), - undef, - "undef/null round-trip $encode_name+decode" - ); -} - -done_testing; diff --git a/t/unit/Test2/Harness/Util/Term.t b/t/unit/Test2/Harness/Util/Term.t deleted file mode 100644 index f620ad504..000000000 --- a/t/unit/Test2/Harness/Util/Term.t +++ /dev/null @@ -1,10 +0,0 @@ -use Test2::V0 -target => 'Test2::Harness::Util::Term'; -# HARNESS-DURATION-SHORT - -use ok $CLASS => qw/USE_ANSI_COLOR/; - -imported_ok(qw/USE_ANSI_COLOR/); - -is(USE_ANSI_COLOR(), in_set(0, 1), "USE_ANSI_COLOR returns true or false"); - -done_testing; diff --git a/t/unit/Test2/Tools/HarnessTester.t b/t/unit/Test2/Tools/HarnessTester.t deleted file mode 100644 index 643de49c2..000000000 --- a/t/unit/Test2/Tools/HarnessTester.t +++ /dev/null @@ -1,46 +0,0 @@ -use Test2::V0 -target => 'Test2::Tools::HarnessTester'; -use Test2::Tools::HarnessTester qw/summarize_events/; - -imported_ok qw/summarize_events/; - -my $events = intercept { - ok(1, "Pass") for 1 .. 4; - ok(0, "Fail"); - ok(1, "Pass"); - - done_testing; -}; - -is( - summarize_events($events), - { - assertions => 6, - errors => 0, - fail => 1, - failures => 1, - pass => 0, - plan => {count => 6}, - }, - "Failure, assertion count, plan", -); - -$events = intercept { - ok(1, "Pass") for 1 .. 4; - - done_testing; -}; - -is( - summarize_events($events), - { - assertions => 4, - errors => 0, - fail => 0, - failures => 0, - pass => 1, - plan => {count => 4}, - }, - "pass, assertion count, plan", -); - -done_testing; diff --git a/t2/builder.t b/t2/builder.t index 71cc3470e..0b20d5782 100644 --- a/t2/builder.t +++ b/t2/builder.t @@ -1,4 +1,6 @@ use Test::More; +use strict; +use warnings; # HARNESS-DURATION-SHORT ok(1, "pass"); diff --git a/t2/ipc_reexec.t b/t2/ipc_reexec.t index 82ac60552..e8b1851b7 100644 --- a/t2/ipc_reexec.t +++ b/t2/ipc_reexec.t @@ -1,5 +1,8 @@ +use strict; +use warnings; # HARNESS-NO-FORK # HARNESS-DURATION-SHORT + BEGIN { $INC{'Test2/Formatter/Stream.pm'} && exec($^X, $0); }; # Force into stdout BEGIN { diff --git a/t2/output.t b/t2/output.t index f19bb8938..9ee679702 100644 --- a/t2/output.t +++ b/t2/output.t @@ -9,8 +9,8 @@ print STDOUT "STDOUT Before any events"; ok(1, "pass"); -print STDERR "STDERR Between events"; -print STDOUT "STDOUT Between events"; +print STDERR " STDERR Between events "; +print STDOUT " STDOUT Between events "; ok(1, "pass"); diff --git a/t2/subtests.t b/t2/subtests.t index bc929311c..d6a36f559 100644 --- a/t2/subtests.t +++ b/t2/subtests.t @@ -11,6 +11,8 @@ my $astA = async_subtest 'ast A'; $astA->run(sub { ok(1, "ast A 1") }); +ok(0); + subtest out => sub { ok(1, "pass"); ok(1, "pass"); diff --git a/template.pod b/template.pod new file mode 100644 index 000000000..7165d20fe --- /dev/null +++ b/template.pod @@ -0,0 +1,48 @@ +=pod + +=encoding UTF-8 + +=head1 NAME + +=head1 DESCRIPTION + +=head1 SYNOPSIS + +=head1 EXPORTS + +=over 4 + +=back + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F<http://github.com/Test-More/Test2-Harness/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut + diff --git a/templib/XXX.pm b/templib/XXX.pm new file mode 100644 index 000000000..e0d1d8f81 --- /dev/null +++ b/templib/XXX.pm @@ -0,0 +1,39 @@ +package XXX; +use strict; +use warnings; + +use Test2::Harness::Preload; + +stage foo => sub { + eager; + + preload "Scalar::Util"; + + preload sub { + 1; + #print "Preload sub ran!\n"; + }; + + stage bar => sub { + preload "List::Util"; + 1; + }; + + stage theone => sub { + preload "Data::Dumper"; + + preload 'YYY'; + + #pre_fork(sub { print STDERR "\n!!! PREFORK! $$ $0\n" }); + #post_fork(sub { print STDERR "\n!!! POSTFORK! $$ $0\n" }); + #pre_launch(sub { print STDERR "\n!!! PRELAUNCH! $$ $0\n" }); + + default(); + }; + + 1; +}; + +stage baz => sub { + 1 +}; diff --git a/templib/YYY.pm b/templib/YYY.pm new file mode 100644 index 000000000..1370da24e --- /dev/null +++ b/templib/YYY.pm @@ -0,0 +1,5 @@ +package YYY; + +sub foo { 'foo' } + +1; diff --git a/xt/author/critic.t b/xt/author/critic.t new file mode 100644 index 000000000..2f4ebcb8a --- /dev/null +++ b/xt/author/critic.t @@ -0,0 +1,7 @@ +use strict; +use warnings; + +use Test2::Require::AuthorTesting; +use Test::Perl::Critic; + +all_critic_ok('lib', 'release-scripts', 't', 't2', 'xt');