gnatcoll-core-21.0.0/ 0000755 0001750 0001750 00000000000 13743647711 014202 5 ustar nicolas nicolas gnatcoll-core-21.0.0/.travis-install.sh 0000644 0001750 0001750 00000002465 13661715457 017601 0 ustar nicolas nicolas set -e
set -x
mkdir -p $TOOLS_DIR || true
cd $TOOLS_DIR
# If not already present, download the GNAT Community installer and the helper
# scripts to use it headless.
if ! [ -f $GNAT_INSTALLER ]
then
if [ "$TRAVIS_OS_NAME" = "osx" ]
then
wget $GNAT_OSX_INSTALLER_URL -O $GNAT_INSTALLER
else
wget $GNAT_LINUX_INSTALLER_URL -O $GNAT_INSTALLER
fi
fi
if ! [ -d gnat_community_install_script ]
then
git clone https://github.com/AdaCore/gnat_community_install_script.git;
else
(cd gnat_community_install_script && git pull)
fi
# If not already installed, install GNAT Community. The script does not work if
# the installation directory already exists, so remove it first.
if ! [ -f "$INSTALL_DIR/bin/gprbuild" ]
then
rm -rf "$INSTALL_DIR"
sh gnat_community_install_script/install_package.sh \
"$GNAT_INSTALLER" "$INSTALL_DIR"
fi
# Log info about the toolchain we use
- which gprbuild && gprbuild --version
# Checkout gprbuild sources (or update them), and then build and install
# Libgpr.
if ! [ -d libgpr-src ]
then
git clone https://github.com/AdaCore/gprbuild libgpr-src;
else
(cd libgpr-src && git pull)
fi
(
cd libgpr-src
make libgpr.build
make libgpr.install
)
# Install e3-testsuite to run GNATCOLL's testsuite
pip install git+https://github.com/AdaCore/e3-testsuite.git
gnatcoll-core-21.0.0/README.md 0000644 0001750 0001750 00000005011 13661715457 015460 0 ustar nicolas nicolas The GNAT Components Collection (GNATcoll) - Core packages
=========================================================
This is the core module of the GNAT Components Collection. Please refer to the
documentation in the `docs/` directory.
Code status
===========
Build status with GNAT GPL 2017
Platform | Status
---------|-------
Linux | [](https://travis-ci.org/AdaCore/gnatcoll-core)
Windows | [](https://ci.appveyor.com/project/github-integration-adacore/gnatcoll-core/branch/master)
Dependencies
------------
GNATCOLL only depends on a recent GNAT compiler. Building it also requires
GPRbuild.
Configuring the build process
-----------------------------
The following variables can be used to configure the build process:
General:
* `prefix`: location of the installation, the default is the running GNAT
installation root.
* `BUILD`: control the build options: `PROD` (default) or `DEBUG`
* `PROCESSORS`: parallel compilation (default is 0, which uses all available
cores)
* `TARGET`: for cross-compilation, auto-detected for native platforms
* `SOURCE_DIR`: for out-of-tree build
* `INTEGRATED`: if `yes` (default is `no`), consider that `prefix` is where the
toolchain is installed and install GNATcoll in a target-dependent
subdirectory. This makes it possible to install GNATcoll multiple times for
the various compilers in the same prefix. Enable this only for cross
compilers.
Module-specific:
* `GNATCOLL_MMAP`: whether MMAP is supported (yes/no) default is "yes"; has no
effect on Windows
* `GNATCOLL_MADVISE`: whether MADVISE is supported (yes/no) default is "yes";
has no effect on Windows
To use the default options:
```sh
$ make setup
```
For example, to setup GNATcoll to install a debug version in
`/opt/libgnatcoll`:
```sh
$ make prefix=/opt/libgnatcoll BUILD=DEBUG install
```
Building
--------
Building all versions of the GNATCOLL Core Packages (static, relocatable and
static-pic) is as easy as running `make` in the top directory. Then, to install
it:
```sh
$ make install
```
Note that underneath, this Makefile uses a GPR project file: `gnatcoll.gpr`.
You can build GNATCOLL using it with GPRbuild, but make sure to use the same
command-line options.
Bug reports
-----------
Please send questions and bug reports to report@adacore.com following
the same procedures used to submit reports with the GNAT toolset itself.
gnatcoll-core-21.0.0/Makefile 0000644 0001750 0001750 00000014005 13661715457 015644 0 ustar nicolas nicolas ##############################################################################
## ##
## GNATCOLL LIBRARY ##
## ##
## Copyright (C) 2017, AdaCore. ##
## ##
## This library is free software; you can redistribute it and/or modify it ##
## under terms of the GNU General Public License as published by the Free ##
## Software Foundation; either version 3, or (at your option) any later ##
## version. This library is distributed in the hope that it will be useful, ##
## but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN# ##
## TABILITY or FITNESS FOR A PARTICULAR PURPOSE. ##
## ##
## As a special exception under Section 7 of GPL version 3, you are granted ##
## additional permissions described in the GCC Runtime Library Exception, ##
## version 3.1, as published by the Free Software Foundation. ##
## ##
## You should have received a copy of the GNU General Public License and ##
## a copy of the GCC Runtime Library Exception along with this program; ##
## see the files COPYING3 and COPYING.RUNTIME respectively. If not, see ##
## . ##
## ##
##############################################################################
# Makefile targets
# ----------------
#
# Setup: make [VAR=VALUE] setup (see below)
# Build: make
# Install: make install
# Variables which can be set:
#
# General:
#
# prefix : root install directory
# ENABLE_SHARED : yes / no (or empty)
# BUILD : DEBUG PROD
# PROCESSORS : nb parallel compilations (0 to use all cores)
# TARGET : target triplet for cross-compilation
# INTEGRATED : installs the project as part of the compiler installation;
# this adds NORMALIZED_TARGET subdir to prefix
#
# Project specific:
#
# GNATCOLL_MMAP : whether MMAP is supported (yes/no)
# default is "yes"; has no effect on Windows
# GNATCOLL_MADVISE : whether MADVISE is supported (yes/no)
# default is "yes"; has no effect on Windows
# helper programs
CAT := cat
ECHO := echo
WHICH := which
# check for out-of-tree build
SOURCE_DIR := $(dir $(MAKEFILE_LIST))
ifeq ($(SOURCE_DIR),./)
RBD=
GNATCOLL_GPR=gnatcoll.gpr
MAKEPREFIX=
else
RBD=--relocate-build-tree
GNATCOLL_GPR=$(SOURCE_DIR)/gnatcoll.gpr
MAKEPREFIX=$(SOURCE_DIR)/
endif
TARGET := $(shell gcc -dumpmachine)
NORMALIZED_TARGET := $(subst normalized_target:,,$(wordlist 6,6,$(shell gprconfig --config=ada --target=$(TARGET) --mi-show-compilers)))
ifeq ($(NORMALIZED_TARGET),)
$(error No toolchain found for target "$(TARGET)")
endif
GNATCOLL_OS := $(if $(findstring darwin,$(NORMALIZED_TARGET)),osx,$(if $(findstring windows,$(NORMALIZED_TARGET)),windows,unix))
prefix := $(dir $(shell $(WHICH) gnatls))..
GNATCOLL_VERSION := $(shell $(CAT) $(SOURCE_DIR)/version_information)
GNATCOLL_MMAP := yes
GNATCOLL_MADVISE := yes
BUILD = PROD
PROCESSORS = 0
BUILD_DIR =
ENABLE_SHARED = yes
INTEGRATED = no
all: build
# Load current setup if any
-include makefile.setup
GTARGET=--target=$(NORMALIZED_TARGET)
ifeq ($(ENABLE_SHARED), yes)
LIBRARY_TYPES=static relocatable static-pic
else
LIBRARY_TYPES=static
endif
ifeq ($(INTEGRATED), yes)
integrated_install=/$(NORMALIZED_TARGET)
endif
GPR_VARS=-XGNATCOLL_MMAP=$(GNATCOLL_MMAP) \
-XGNATCOLL_MADVISE=$(GNATCOLL_MADVISE) \
-XGNATCOLL_VERSION=$(GNATCOLL_VERSION) \
-XGNATCOLL_OS=$(GNATCOLL_OS) \
-XBUILD=$(BUILD)
# Used to pass extra options to GPRBUILD, like -d for instance
GPRBUILD_OPTIONS=
BUILDER=gprbuild -p -m $(GTARGET) $(RBD) -j$(PROCESSORS) $(GPR_VARS) \
$(GPRBUILD_OPTIONS)
INSTALLER=gprinstall -p -f $(GTARGET) $(GPR_VARS) \
$(RBD) --sources-subdir=include/gnatcoll --prefix=$(prefix)$(integrated_install)
CLEANER=gprclean -q $(RBD) $(GTARGET)
UNINSTALLER=$(INSTALLER) -p -f --install-name=gnatcoll --uninstall
#########
# build #
#########
build: $(LIBRARY_TYPES:%=build-%)
build-%:
$(BUILDER) -XLIBRARY_TYPE=$* -XXMLADA_BUILD=$* -XGPR_BUILD=$* \
$(GPR_VARS) $(GNATCOLL_GPR)
###########
# Install #
###########
uninstall:
ifneq (,$(wildcard $(prefix)$(integrated_install)/share/gpr/manifests/gnatcoll))
$(UNINSTALLER) $(GNATCOLL_GPR)
endif
install: uninstall $(LIBRARY_TYPES:%=install-%)
install-%:
$(INSTALLER) -XLIBRARY_TYPE=$* -XXMLADA_BUILD=$* -XGPR_BUILD=$* \
--build-name=$* $(GPR_VARS) \
--build-var=LIBRARY_TYPE --build-var=GNATCOLL_BUILD \
--build-var=GNATCOLL_CORE_BUILD $(GNATCOLL_GPR)
###########
# Cleanup #
###########
clean: $(LIBRARY_TYPES:%=clean-%)
clean-%:
-$(CLEANER) -XLIBRARY_TYPE=$* -XXMLADA_BUILD=$* -XGPR_BUILD=$* \
$(GPR_VARS) $(GNATCOLL_GPR)
#########
# setup #
#########
.SILENT: setup
setup:
$(ECHO) "prefix=$(prefix)" > makefile.setup
$(ECHO) "ENABLE_SHARED=$(ENABLE_SHARED)" >> makefile.setup
$(ECHO) "INTEGRATED=$(INTEGRATED)" >> makefile.setup
$(ECHO) "BUILD=$(BUILD)" >> makefile.setup
$(ECHO) "PROCESSORS=$(PROCESSORS)" >> makefile.setup
$(ECHO) "TARGET=$(TARGET)" >> makefile.setup
$(ECHO) "SOURCE_DIR=$(SOURCE_DIR)" >> makefile.setup
$(ECHO) "GNATCOLL_OS=$(GNATCOLL_OS)" >> makefile.setup
$(ECHO) "GNATCOLL_VERSION=$(GNATCOLL_VERSION)" >> makefile.setup
$(ECHO) "GNATCOLL_MMAP=$(GNATCOLL_MMAP)" >> makefile.setup
$(ECHO) "GNATCOLL_MADVISE=$(GNATCOLL_MADVISE)" >> makefile.setup
# Let gprbuild handle parallelisation. In general, we don't support parallel
# runs in this Makefile, as concurrent gprinstall processes may crash.
.NOTPARALLEL:
gnatcoll-core-21.0.0/testsuite/ 0000755 0001750 0001750 00000000000 13743647711 016233 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/run-tests 0000755 0001750 0001750 00000015217 13743647711 020133 0 ustar nicolas nicolas #!/usr/bin/env python
from drivers import make_gnatcoll, TESTSUITE_ROOT_DIR
from drivers.basic import BasicTestDriver
from drivers.json_validation import JSONValidationDriver
from drivers.data_validation import DataValidationDriver
from drivers.gnatcov import list_to_file, produce_report
from e3.testsuite import Testsuite
from e3.fs import mkdir, ls, find, rm
from e3.os.process import Run
import re
import os
import logging
class MyTestsuite(Testsuite):
enable_cross_support = True
tests_subdir = 'tests'
test_driver_map = {
'json_validation': JSONValidationDriver,
'data_validation': DataValidationDriver,
'default': BasicTestDriver}
def add_options(self, parser):
parser.add_argument(
'--gcov',
help="compute code coverage of GNATcoll with gcov",
default=False,
action="store_true")
parser.add_argument(
'--gnatcov',
help="compute code coverage of GNATcoll with GNATcoverage",
default=False,
action="store_true")
parser.add_argument(
'--valgrind',
help="check memory usage with Valgrind (memcheck tool)",
action="store_true")
parser.add_argument(
'--recompile',
help="recompile debug version of gnatcoll for testing",
default=False,
action="store_true")
def set_up(self):
self.env.gcov = self.main.args.gcov
self.env.gnatcov = self.main.args.gnatcov
self.env.valgrind = self.main.args.valgrind
self.env.enable_cleanup = self.main.args.enable_cleanup
# Reject incompatible options
incompatible = [name for name in ('gcov', 'gnatcov', 'valgrind')
if getattr(self.env, name)]
if len(incompatible) > 1:
raise RuntimeError('The following options are incompatible: {}'
.format(' '.join(incompatible)))
# If doing a gcov or GNATcoverage-based testsuite run, rebuild GNATcoll
# accordingly and update directories.
if self.env.gcov or self.env.gnatcov:
if self.env.gcov:
subdir = 'gcov'
else:
subdir = 'gnatcov'
work_dir = os.path.join(TESTSUITE_ROOT_DIR, subdir)
gpr_dir, src_dir, obj_dir = make_gnatcoll(
work_dir, gcov=self.env.gcov, gnatcov=self.env.gnatcov)
self.env.gnatcoll_gpr_dir = gpr_dir
self.env.gnatcoll_src_dir = src_dir
self.env.gnatcoll_obj_dir = obj_dir
if self.env.gnatcov:
# Prepare a directory to host checkpoint files. Make sure it's
# empty so that we don't re-use coverage data from previous
# runs.
self.env.checkpoints_dir = os.path.join(
TESTSUITE_ROOT_DIR, 'gnatcov', 'checkpoints')
rm(self.env.checkpoints_dir, recursive=True)
mkdir(self.env.checkpoints_dir)
# Gather the list of ALI files
self.env.ali_files_list = os.path.join(
self.env.gnatcoll_obj_dir, 'ali_files.txt')
list_to_file(find(self.env.gnatcoll_obj_dir, '*.ali'),
self.env.ali_files_list)
else:
self.env.gnatcoll_gpr_dir = None
if self.main.args.recompile:
work_dir = os.path.join(TESTSUITE_ROOT_DIR, 'debug')
gpr_dir, _, _ = make_gnatcoll(work_dir, debug=True)
self.env.gnatcoll_debug_gpr_dir = gpr_dir
if self.env.gnatcoll_gpr_dir is None:
self.env.gnatcoll_gpr_dir = gpr_dir
else:
self.env.gnatcoll_debug_gpr_dir = None
def tear_down(self):
wd = TESTSUITE_ROOT_DIR
# If requested, produce coverage reports
if self.env.gcov:
# We need to call gcov on gcda present both in gnatcoll itself and
# tests (for generics coverage).
gcda_files = \
find(os.path.join(self.env.gnatcoll_obj_dir), '*.gcda') + \
find(os.path.join(self.env.working_dir), '*.gcda')
mkdir(os.path.join(wd, 'gcov', 'results'))
gcr = os.path.join(wd, 'gcov', 'results')
Run(['gcov'] + gcda_files,
cwd=os.path.join(wd, 'gcov', 'results'))
total_sources = 0
total_covered = 0
for source_file in ls(
os.path.join(self.env.gnatcoll_src_dir, '*')):
base_file = os.path.basename(source_file)
if not os.path.isfile(os.path.join(gcr, base_file + '.gcov')):
total = 1
covered = 0
with open(source_file) as fd:
total = len([line for line in fd
if line.strip() and
not re.match(r' *--', line)])
else:
with open(os.path.join(gcr, base_file + '.gcov')) as fd:
total = 0
covered = 0
for line in fd:
if re.match(r' *-:', line):
pass
elif re.match(r' *[#=]{5}:', line):
total += 1
else:
total += 1
covered += 1
total_sources += total
total_covered += covered
logging.info('%6.2f %% %8d/%-8d %s',
float(covered) * 100.0 / float(total),
covered,
total,
os.path.basename(source_file))
logging.info('%6.2f %% %8d/%-8d %s',
float(total_covered) * 100.0 / float(total_sources),
total_covered,
total_sources,
'TOTAL')
elif self.env.gnatcov:
checkpoint_list = os.path.join(wd, 'gnatcov', 'checkpoints',
'checkpoint_list.txt')
list_to_file(find(self.env.checkpoints_dir, '*.ckpt'),
checkpoint_list)
produce_report(os.path.join(wd, 'gnatcov', 'results'),
checkpoint_list,
self.env.gnatcoll_src_dir)
super(MyTestsuite, self).tear_down()
@property
def default_driver(self):
return 'default'
if __name__ == '__main__':
suite = MyTestsuite(os.path.dirname(__file__))
suite.testsuite_main()
gnatcoll-core-21.0.0/testsuite/README.md 0000644 0001750 0001750 00000011731 13661715457 017517 0 ustar nicolas nicolas Running GNATcoll Testsuite
==========================
`The testsuite is currently under construction !`
Getting Started
-------------------
To run it you need to have **Python** installed along with the package
**e3-testsuite**.
To install e3-testsuite:
```sh
pip install git+https://github.com/AdaCore/e3-testsuite.git
```
Then do
```sh
./run-tests
```
By default the test suite will be run with the **GNATcoll** library found in
the environment.
A summary of the results will be displayed once the testsuite ends. Detailed
results and logs can be found for each test in the `out/new` subdirectory. In
this directory a **YaML** file will be created for each test.
In order to have coverage information with **gcov**, just add `--gcov`. It
will recompiles **GNATcoll** with coverage information and a summary of the
coverage information will be displayed at the end of the test suite run. Full
coverage information can be found in `gcov/results` subdirectory.
Running the testsuite
--------------------------
### Partial Runs
In some contexts, it might be useful to run only subsets of the testsuite. In
order to do so you can use two different workflows.
#### E3-test
Call ``e3-test`` from any subdirectory of the testsuite will run only the
tests contained in that directory. This workflow is useful when working for
example in a single tests. By default you the testsuite will be run with
default parameters, but you can adjust the default parameters by editing the
**YaML** file called ``e3-test.yaml`` located in the root directory of the
testsuite. The ``default_args`` can be used to add default parameters such
as ``--gcov`` for example.
#### Run-tests
Call ``./run-tests`` with a list of test directories
### Which GNATcoll library is used ?
If the testsuite is launched without any argument, then the **GNATcoll** from
the user environment will be picked. If you add ``--gcov`` switch then
**GNATcoll** will be recompiled using sources from your current checkout. This
**GNATcoll** will be used for all tests except the one with the ``no-coverage``
marker in their description (see format of ``test.yaml`` section). Adding
``--recompile`` will recompile a **GNATcoll** library in production mode to
be used by the testsuite. If both ``--gcov`` and ``--recompile`` are used then
the production mode version of the library will be used only for tests with
the ``no-coverage`` marker (might be useful for tests doing some performance
measurement).
### Reference
Run ``run-tests --help`` to get the full list of options
Writing tests
-------------
Testcases are found in the ``tests`` subdirectory. A testcase is a directory
containing the file called `test.yaml`.
A ``test.yaml`` looks like:
```yaml
# Mandatory
description: My test description
# Specify the test driver to be used. If not specified the default driver
# called 'default' is used
driver: driver_name
```
Some additional information which is driver specific might be present. To get
a list of available drivers look for ``DRIVERS`` dictionary in run-tests
script. From there you will be able to locate the **Python** class that
implement that driver along with its docstring.
### The default driver
In this readme we will only document the default driver. The default driver follow
the following workflow:
1. Check if the test should be skipped.
2. If not build the test
3. Run the test and check that the output contains some expected patterns
A minimal test should contains only one **Ada** unit called ``test.adb`` that
contains a function ``Test``. The skeleton of that function should look like
```ada
-- Following unit is provided by the testsuite in support subdirectory
with Test_Assert;
function Test return Integer is
begin
Test_Assert.Assert (True, "my test is ok :-)");
return Test_Assert.Report;
end Test;
```
You can override the default project by creating a file called ``test.gpr`` in
the test directory. You can also changed the name of the executable that is
executed by setting the ``test_exe`` key in ``test.yaml`` (default value is
``obj/test``).
For some specific case for which you never want to enable coverage
instrumentation, just add ``no-coverage: True`` to ``test.yaml``.
If you need some data files while running your tests, you need to specify them
using the ``data`` key. For example:
```yaml
description: Loading projects
data:
- "*.gpr"
```
Will copy all local ``.gpr`` files to the working directory before executing
the test.
Test can also be skipped based on a set of given conditions. For example:
```yaml
description: A test
skip:
- ['XFAIL', 'env.build.os.name == "windows"']
```
The skip entry is a list of tuple of the form (status, condition). If the
condition (a **Python** expression) is True then test is skipped and test
status set to ``status``. Note that currently only the following symbols are
available in the conditions: ``env`` (a BaseEnv object), ``test_env`` (the
test.yaml file as a **Python** dict) and the function ``disk_space`` (return
the available disk space in the working directory).
gnatcoll-core-21.0.0/testsuite/e3-test.yaml 0000644 0001750 0001750 00000000041 13661715457 020400 0 ustar nicolas nicolas main: run-tests
default_args: []
gnatcoll-core-21.0.0/testsuite/drivers/ 0000755 0001750 0001750 00000000000 13743647711 017711 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/drivers/valgrind.py 0000644 0001750 0001750 00000001007 13743647711 022067 0 ustar nicolas nicolas from drivers import bin_check_call
def check_call_valgrind(driver, cmd, test_name=None, result=None, **kwargs):
"""
Wrapper for `e3.testsuite.process` that runs the process under Valgrind if
this is a Valgrind-checked testsuite run. The process exit status will be
2 if Valgrind finds memory issues.
"""
if driver.env.valgrind:
cmd = ['valgrind', '-q', '--error-exitcode=2',
'--leak-check=full'] + cmd
return bin_check_call(driver, cmd, test_name, result, **kwargs)
gnatcoll-core-21.0.0/testsuite/drivers/basic.py 0000644 0001750 0001750 00000004131 13743647711 021343 0 ustar nicolas nicolas import os
from e3.fs import cp
from e3.os.fs import df
from e3.testsuite.driver.classic import ClassicTestDriver
from e3.testsuite.control import YAMLTestControlCreator
from drivers import gprbuild, run_test_program
class BasicTestDriver(ClassicTestDriver):
"""Default GNATcoll testsuite driver.
In order to declare a test:
1- Create a directory with a test.yaml inside
2- Add test sources in that directory
3- Add a main called test.adb that use support/test_assert.ads package.
4- Do not put test.gpr there, it breaks the test, if you need a project
file for testing, name it something else.
5- If you need additional files for you test, list them in test.yaml:
data:
- "your_file1"
- "your_file2"
"""
# We want to copy only specific files (files referenced by the "data" key
# in test.yaml).
copy_test_directory = False
@property
def test_control_creator(self):
return YAMLTestControlCreator({
'env': self.env,
'test_env': self.test_env,
'disk_space': lambda: df(self.env.working_dir)
})
def run(self):
# Build the test program
if self.test_env.get('no-coverage'):
gpr_project_path = self.env.gnatcoll_debug_gpr_dir
else:
gpr_project_path = self.env.gnatcoll_gpr_dir
gprbuild(self, gcov=self.env.gcov, gpr_project_path=gpr_project_path)
# Copy the requested data files
for data in self.test_env.get('data', []):
cp(os.path.join(self.test_env['test_dir'], data),
self.test_env['working_dir'], recursive=True)
# Run the test program
test_exe = self.test_env.get('test_exe', 'obj/test')
process = run_test_program(
self,
[os.path.join(self.test_env['working_dir'], test_exe)],
timeout=self.default_process_timeout)
self.output += process.out.decode('utf-8')
def compute_failures(self):
return (['Success marker not found']
if '<=== TEST PASSED ===>' not in self.result.log.log else [])
gnatcoll-core-21.0.0/testsuite/drivers/__init__.py 0000644 0001750 0001750 00000020461 13743647711 022025 0 ustar nicolas nicolas import logging
import os
import subprocess
from e3.fs import mkdir
from e3.os.process import Run, get_rlimit
from e3.testsuite import TestAbort
from e3.testsuite.driver import TestDriver
from e3.testsuite.driver.classic import (
ClassicTestDriver, ProcessResult, TestAbortWithFailure
)
from e3.testsuite.process import check_call
from e3.testsuite.result import Log, TestStatus
# Root directory of respectively the testsuite and the gnatcoll
# repository.
TESTSUITE_ROOT_DIR = os.path.dirname(
os.path.dirname(os.path.abspath(__file__)))
GNATCOLL_ROOT_DIR = os.path.dirname(TESTSUITE_ROOT_DIR)
DEFAULT_TIMEOUT = 5 * 60 # 5 minutes
def make_gnatcoll(work_dir, debug=False, gcov=False, gnatcov=False):
"""Build gnatcoll core with or without gcov instrumentation.
:param str work_dir: Working directory. GNATcoll is built in `build` subdir
and installed in `install` subdir.
:param bool debug: Whether to build GNATCOLL in debug mode. Otherwise, use
the prod mode. Note that gcov and gnatcov modes automatically enable
debug mode.
:param bool gcov: If true, build GNATCOLL with gcov instrumentation in
debgu mode.
:param bool gnatcov: If True, build GNATCOLL with the compile options that
GNATcoverage require in debug mode.
:return: A triplet (project path, source path, object path).
:rtype: (str, str, str)
:raise AssertError: In case compilation of installation fails.
"""
assert not (gcov and gnatcov)
if gcov:
tag = ' (gcov)'
elif gnatcov:
tag = ' (gnatcov)'
else:
tag = ''
logging.info('Compiling gnatcoll{}'.format(tag))
# Create build tree structure
build_dir = os.path.join(work_dir, 'build')
install_dir = os.path.join(work_dir, 'install')
mkdir(build_dir)
mkdir(install_dir)
# Compute make invocation
make_gnatcoll_cmd = [
'make', '-f', os.path.join(GNATCOLL_ROOT_DIR, 'Makefile'),
'ENABLE_SHARED=no',
'BUILD={}'.format('DEBUG' if debug or gcov or gnatcov else 'PROD')]
if gcov:
make_gnatcoll_cmd += [
'GPRBUILD_OPTIONS=-cargs -fprofile-arcs -ftest-coverage'
' -cargs:Ada -gnatwn'
' -gargs']
elif gnatcov:
make_gnatcoll_cmd += [
'GPRBUILD_OPTIONS=-cargs -fdump-scos -fpreserve-control-flow'
' -gargs']
# Build & Install
p = Run(make_gnatcoll_cmd, cwd=build_dir, timeout=DEFAULT_TIMEOUT)
assert p.status == 0, "gnatcoll build failed:\n%s" % p.out
p = Run(make_gnatcoll_cmd + ['prefix=%s' % install_dir, 'install'],
cwd=build_dir, timeout=DEFAULT_TIMEOUT)
assert p.status == 0, "gnatcoll installation failed:\n%s" % p.out
return (os.path.join(install_dir, 'share', 'gpr'),
os.path.join(install_dir, 'include', 'gnatcoll'),
os.path.join(build_dir, 'obj', 'gnatcoll', 'static'))
def gprbuild(driver,
project_file=None,
cwd=None,
gcov=False,
scenario=None,
gpr_project_path=None,
timeout=DEFAULT_TIMEOUT,
**kwargs):
"""Launch gprbuild.
:param project_file: project file to compile. If None, we looks first for
a test.gpr in the test dir and otherwise fallback on the common
test.gpr project of the support subdir of the testsuite.
:type project_file: str
:param cwd: directory in which to run gprbuild. If None the gprbuild build
is run in the default working dir for the test.
:type cwd: str | None
:param gcov: if True link with gcov libraries
:type gcov: bool
:param scenario: scenario variable values
:type scenario: dict
:param gpr_project_path: if not None prepent this value to GPR_PROJECT_PATH
:type gpr_project_path: None | str
:param kwargs: additional keyword arguements are passed to
e3.testsuite.process.check_call function
:return: True on successful completion
:rtype: bool
"""
if scenario is None:
scenario = {}
if project_file is None:
project_file = os.path.join(driver.test_env['test_dir'],
'test.gpr')
if not os.path.isfile(project_file):
project_file = os.path.join(TESTSUITE_ROOT_DIR,
'support', 'test.gpr')
scenario['TEST_SOURCES'] = driver.test_env['test_dir']
if cwd is None:
cwd = driver.test_env['working_dir']
mkdir(cwd)
gprbuild_cmd = [
'gprbuild', '--relocate-build-tree', '-p', '-P', project_file]
for k, v in scenario.items():
gprbuild_cmd.append('-X%s=%s' % (k, v))
if gcov:
gprbuild_cmd += ['-largs', '-lgcov', '-cargs',
'-fprofile-arcs', '-ftest-coverage', '-g']
elif driver.env.gnatcov:
# TODO: GNATcoverage relies on debug info to do its magic. It needs
# consistent paths to source files in the debug info, so do not build
# tests with debug info, as they will reference installed sources
# (while GNATCOLL objects reference original sources).
gprbuild_cmd += ['-g0']
# Adjust process environment
env = kwargs.pop('env', None)
ignore_environ = kwargs.pop('ignore_environ', True)
if env is None:
env = {}
ignore_environ = False
if gpr_project_path:
new_gpr_path = gpr_project_path
if 'GPR_PROJECT_PATH' in os.environ:
new_gpr_path += os.path.pathsep + os.environ['GPR_PROJECT_PATH']
env['GPR_PROJECT_PATH'] = new_gpr_path
check_call(
driver,
gprbuild_cmd,
cwd=cwd,
env=env,
ignore_environ=ignore_environ,
timeout=timeout,
**kwargs)
# If we get there it means the build succeeded.
return True
def bin_check_call(driver, cmd, test_name=None, result=None, timeout=None,
env=None, cwd=None):
if cwd is None and "working_dir" in driver.test_env:
cwd = driver.test_env["working_dir"]
if result is None:
result = driver.result
if test_name is None:
test_name = driver.test_name
if timeout is not None:
cmd = [get_rlimit(), str(timeout)] + cmd
# Use directly subprocess instead of e3.os.process.Run, since the latter
# does not handle binary outputs.
subp = subprocess.Popen(
cmd, cwd=cwd, env=env, stdin=subprocess.DEVNULL,
stdout=subprocess.PIPE, stderr=subprocess.STDOUT
)
stdout, _ = subp.communicate()
process = ProcessResult(subp.returncode, stdout)
result.processes.append(
{
"output": Log(stdout),
"status": process.status,
"cmd": cmd,
"timeout": timeout,
"env": env,
"cwd": cwd,
}
)
# Append the status code and process output to the log to ease post-mortem
# investigation.
result.log += "Status code: {}\n".format(process.status)
result.log += "Output:\n"
try:
stdout = stdout.decode('utf-8')
except UnicodeDecodeError:
stdout = str(stdout)
result.log += stdout
if process.status != 0:
if isinstance(driver, ClassicTestDriver):
raise TestAbortWithFailure('command call fails')
else:
result.set_status(TestStatus.FAIL, "command call fails")
driver.push_result(result)
raise TestAbort
return process
def run_test_program(driver, cmd, test_name=None, result=None, **kwargs):
"""
Run a test program. This dispatches to running it under Valgrind or
"gnatcov run", depending on the testsuite options.
"""
from drivers.gnatcov import gnatcov_run
from drivers.valgrind import check_call_valgrind
if driver.env.valgrind:
wrapper = check_call_valgrind
elif driver.env.gnatcov:
wrapper = gnatcov_run
else:
wrapper = bin_check_call
return wrapper(driver, cmd, test_name, result, **kwargs)
class GNATcollTestDriver(TestDriver):
"""Abstract class to share some common facilities."""
DEFAULT_TIMEOUT = 5 * 60 # 5 minutes
@property
def process_timeout(self):
"""Timeout (in seconds) for subprocess to launch."""
return self.test_env.get('timeout', self.DEFAULT_TIMEOUT)
def run_test_program(self, cmd, test_name=None, result=None, **kwargs):
return run_test_program(self, cmd, test_name, result, **kwargs)
gnatcoll-core-21.0.0/testsuite/drivers/data_validation.py 0000644 0001750 0001750 00000005464 13743647711 023417 0 ustar nicolas nicolas from e3.fs import rm
from e3.testsuite.result import TestStatus, TestResult
from drivers import GNATcollTestDriver, gprbuild
import os
class DataValidationDriver(GNATcollTestDriver):
"""Data validation driver.
For each test program call the program with data file defined in
data_files key of the test. If the program returns 0 assume that
the test passed.
"""
def add_test(self, dag):
self.add_fragment(dag, 'build')
tear_down_deps = []
for data_file, description in self.test_env['data_files'].items():
tear_down_deps.append(data_file)
self.add_fragment(
dag,
data_file,
fun=self.run_subtest_for(data_file, description),
after=['build'])
self.add_fragment(dag, 'tear_down', after=tear_down_deps)
def run_subtest_for(self, data_file, description):
def run_subtest(previous_values, slot):
test_name = self.test_name + '.' + data_file
result = TestResult(test_name, env=self.test_env)
if not previous_values['build']:
return TestStatus.FAIL
process = self.run_test_program(
[os.path.join(self.test_env['working_dir'],
self.test_env.get('validator', 'obj/test')),
os.path.join(self.test_env['test_dir'], data_file)],
test_name=test_name,
result=result,
timeout=self.process_timeout)
return self.validate_result(process, data_file, result)
return run_subtest
def validate_result(self, process, data_file, result):
# Test passes as soon as there is this magic string is its output. Note
# that we push a test result only on failure.
if b'<=== TEST PASSED ===>' not in process.out:
result.set_status(TestStatus.FAIL)
self.push_result(result)
return True
def tear_down(self, previous_values, slot):
# If the test program build failed, there is nothing we can do (and the
# result for this test is alredy pushed anyway).
if not previous_values.get('build'):
return False
failures = [v for v in previous_values.values() if
not isinstance(v, TestStatus) or v != TestStatus.PASS]
if failures:
self.result.set_status(TestStatus.FAIL,
msg="%s subtests failed" % len(failures))
else:
self.result.set_status(TestStatus.PASS)
self.push_result()
if self.env.enable_cleanup:
rm(self.test_env['working_dir'], recursive=True)
def build(self, previous_values, slot):
return gprbuild(self, gcov=self.env.gcov,
gpr_project_path=self.env.gnatcoll_gpr_dir)
gnatcoll-core-21.0.0/testsuite/drivers/gnatcov.py 0000644 0001750 0001750 00000005417 13743647711 021733 0 ustar nicolas nicolas import logging
import os
from e3.os.process import Run
from drivers import bin_check_call
COVERAGE_LEVEL = 'stmt+decision'
def list_to_file(str_list, filename):
"""Write a list of strings to a text file.
:param list[str] str_list: List of strings to write.
:param str filename: Name of the destination file.
"""
with open(filename, 'w') as f:
for item in str_list:
f.write(item + '\n')
def gnatcov_run(driver, cmd, test_name=None, result=None, **kwargs):
"""
Wrapper for `bin_check_call` that runs the process under
"gnatcov run" and that produces a checkpoint in
`driver.env.checkpoints_dir` for the corresponding partial coverage report.
"""
test_name = test_name or driver.test_env['test_name']
trace_file = os.path.join(driver.test_env['working_dir'],
'{}.trace'.format(test_name))
checkpoint_file = os.path.join(driver.env.checkpoints_dir,
'{}.ckpt'.format(test_name))
cmd = ['gnatcov', 'run', '-o', trace_file, '-eargs'] + cmd
result = bin_check_call(driver, cmd, test_name, result, **kwargs)
p = Run(['gnatcov', 'coverage',
'--level={}'.format(COVERAGE_LEVEL),
'--scos=@{}'.format(driver.env.ali_files_list),
'--save-checkpoint={}'.format(checkpoint_file),
trace_file])
if p.status:
logging.error('converting gnatcov trace file to checkpoint failed:\n'
'{}'.format(p.out))
return result
def produce_report(output_dir, checkpoint_list, src_dir):
"""Produce a coverage reports.
:param str output_dir: Name of the directory to contain the DHTML coverage
report.
:param str checkpoint_list: Name of the file that contains the list of
checkpoints to use.
:param str src_dir: Name of the directory that contains installed sources.
"""
args = ['gnatcov', 'coverage', '--annotate=dhtml',
'--level={}'.format(COVERAGE_LEVEL),
'--output-dir={}'.format(output_dir),
'--checkpoint=@{}'.format(checkpoint_list),
# TODO: GNATcoverage is not be able to find the source file for a
# unit that is not used by any test program. This is a problem for
# units that are not tested at all. Let it know where to find the
# source file to avoid spurious warnings. Note that these units are
# reported as uncovered in any case.
'--source-search={}'.format(src_dir)]
p = Run(args, output=None)
if p.status:
logging.error('could not produce the coverage report:\n'
'{}'.format(p.out))
elif p.out:
logging.info('output of "gnatcov coverage" is not empty:\n'
'{}'.format(p.out))
gnatcoll-core-21.0.0/testsuite/drivers/json_validation.py 0000644 0001750 0001750 00000001726 13743647711 023454 0 ustar nicolas nicolas from e3.testsuite.result import TestStatus
from drivers.data_validation import DataValidationDriver
import os
import json
import logging
class JSONValidationDriver(DataValidationDriver):
def validate_result(self, process, data_file, result):
# Read data file
with open(os.path.join(self.test_env['test_dir'], data_file),
encoding='utf-8') as fd:
expected = json.load(fd)
got = json.loads(process.out.decode('utf-8'))
if got != expected:
# Escape non-ASCII codepoints. This is necessary to avoid errors
# when logging wide characters on ancient encodings, such as CP1252
# on Windows.
got = got.encode('unicode_escape').decode('ascii')
expected = expected.encode('unicode_escape').decode('ascii')
logging.debug('%s\n<=>\n%s', got, expected)
result.set_status(TestStatus.FAIL)
result.push_result()
return True
gnatcoll-core-21.0.0/testsuite/support/ 0000755 0001750 0001750 00000000000 13661715457 017751 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/support/test_remote.ads 0000644 0001750 0001750 00000007435 13661715457 023005 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
-- The package provides remote support using only local resources. This
-- allows to test remote functionalities without the need for a remote host.
with GNAT.Expect;
with GNAT.Strings;
with GNATCOLL.Remote;
with GNATCOLL.VFS_Types;
with GNATCOLL.Remote.DB;
package Test_Remote is
package GR renames GNATCOLL.Remote;
package GRDB renames GNATCOLL.Remote.DB;
package GVT renames GNATCOLL.VFS_Types;
-- Declare local transport protocol (basically spawn /bin/bash)
type Local_Transport is new GR.Server_Record with null record;
function Nickname (Server : Local_Transport) return String;
function Shell_FS (Server : Local_Transport) return GVT.FS_Type;
procedure Execute_Remotely
(Server : access Local_Transport;
Args : GNAT.Strings.String_List;
Status : out Boolean;
Execution_Directory : GVT.FS_String := "");
procedure Execute_Remotely
(Server : access Local_Transport;
Args : GNAT.Strings.String_List;
Result : out GNAT.Strings.String_Access;
Status : out Boolean;
Execution_Directory : GVT.FS_String := "");
procedure Spawn_Remotely
(Server : access Local_Transport;
Descriptor : out GNAT.Expect.Process_Descriptor_Access;
Args : GNAT.Strings.String_List);
-- Declare local remote database which holds only one host nickname
-- called local_test
type Local_DB is new GRDB.Remote_Db_Interface with null record;
function Is_Configured
(Config : Local_DB;
Nickname : String)
return Boolean;
function Get_Server
(Config : Local_DB;
Nickname : String)
return GR.Server_Access;
function Nb_Mount_Points
(Config : Local_DB;
Nickname : String)
return Natural;
function Get_Mount_Point_Local_Root
(Config : Local_DB;
Nickname : String;
Index : Natural)
return GVT.FS_String;
function Get_Mount_Point_Host_Root
(Config : Local_DB;
Nickname : String;
Index : Natural) return GVT.FS_String;
end Test_Remote;
gnatcoll-core-21.0.0/testsuite/support/test.ads 0000644 0001750 0001750 00000000036 13661715457 021420 0 ustar nicolas nicolas function Test return Integer;
gnatcoll-core-21.0.0/testsuite/support/test_remote.adb 0000644 0001750 0001750 00000014572 13661715457 022764 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with GNAT.OS_Lib;
with GNAT.Directory_Operations;
with GNAT.Expect;
with GNAT.Expect.TTY;
with Ada.Text_IO;
with GNATCOLL.Utils;
package body Test_Remote is
package Expect renames GNAT.Expect;
package OS renames GNAT.OS_Lib;
package OS_Path renames GNAT.Directory_Operations;
package IO renames Ada.Text_IO;
use type GVT.FS_String;
--------------
-- Nickname --
--------------
function Nickname (Server : Local_Transport) return String is
begin
return "local";
end Nickname;
--------------
-- Shell_FS --
--------------
function Shell_FS (Server : Local_Transport) return GVT.FS_Type is
begin
return GVT.FS_Unix;
end Shell_FS;
----------------------
-- Execute_Remotely --
----------------------
procedure Execute_Remotely
(Server : access Local_Transport;
Args : GNAT.Strings.String_List;
Status : out Boolean;
Execution_Directory : GVT.FS_String := "")
is
CWD : constant String := OS_Path.Get_Current_Dir;
Script : constant String := GNATCOLL.Utils.Join (" ", Args);
Program_Name : constant String := "/bin/bash";
Program_Args : GNAT.Strings.String_List (1 .. 2) :=
(1 => new String'("-c"), 2 => new String'(Script));
begin
if Execution_Directory /= "" then
OS_Path.Change_Dir (String (Execution_Directory));
end if;
OS.Spawn (Program_Name, Program_Args, Status);
if Execution_Directory /= "" then
OS_Path.Change_Dir (String (CWD));
end if;
end Execute_Remotely;
----------------------
-- Execute_Remotely --
----------------------
procedure Execute_Remotely
(Server : access Local_Transport;
Args : GNAT.Strings.String_List;
Result : out GNAT.Strings.String_Access;
Status : out Boolean;
Execution_Directory : GVT.FS_String := "")
is
CWD : constant String := OS_Path.Get_Current_Dir;
Program_Name : constant String := Args (1).all;
Program_Args : constant GNAT.Strings.String_List :=
Args (2 .. Args'Last);
Int_Status : aliased Integer;
begin
if Execution_Directory /= "" then
OS_Path.Change_Dir (String (Execution_Directory));
end if;
IO.Put_Line (Program_Name);
Result :=
new String'
(Expect.Get_Command_Output
(Program_Name, Program_Args, "", Int_Status'Access, True));
if Int_Status = 0 then
Status := True;
else
Status := False;
end if;
if Execution_Directory /= "" then
OS_Path.Change_Dir (String (CWD));
end if;
end Execute_Remotely;
--------------------
-- Spawn_Remotely --
--------------------
procedure Spawn_Remotely
(Server : access Local_Transport;
Descriptor : out GNAT.Expect.Process_Descriptor_Access;
Args : GNAT.Strings.String_List)
is
Program_Name : constant String := Args (1).all;
Program_Args : constant GNAT.Strings.String_List :=
Args (2 .. Args'Last);
begin
Descriptor := new GNAT.Expect.TTY.TTY_Process_Descriptor;
IO.Put_Line (Program_Name);
Expect.Non_Blocking_Spawn (Descriptor.all, Program_Name, Program_Args);
end Spawn_Remotely;
-------------------
-- Is_Configured --
-------------------
function Is_Configured (Config : Local_DB; Nickname : String) return Boolean
is
begin
if Nickname = "local_test" then
return True;
else
return False;
end if;
end Is_Configured;
----------------
-- Get_Server --
----------------
function Get_Server
(Config : Local_DB;
Nickname : String) return GR.Server_Access
is
begin
return new Local_Transport;
end Get_Server;
---------------------
-- Nb_Mount_Points --
---------------------
function Nb_Mount_Points
(Config : Local_DB;
Nickname : String) return Natural
is
begin
return 1;
end Nb_Mount_Points;
--------------------------------
-- Get_Mount_Point_Local_Root --
--------------------------------
function Get_Mount_Point_Local_Root
(Config : Local_DB;
Nickname : String;
Index : Natural) return GVT.FS_String
is
begin
return "/tmp/local_vfs";
end Get_Mount_Point_Local_Root;
-------------------------------
-- Get_Mount_Point_Host_Root --
-------------------------------
function Get_Mount_Point_Host_Root
(Config : Local_DB;
Nickname : String;
Index : Natural) return GVT.FS_String
is
begin
return "/tmp/remote_vfs";
end Get_Mount_Point_Host_Root;
end Test_Remote;
gnatcoll-core-21.0.0/testsuite/support/test.gpr 0000644 0001750 0001750 00000001277 13661715457 021451 0 ustar nicolas nicolas -- Default project use for tests
--
-- The scenario variable TEST_SOURCES is automatically set by the
-- driver to point to the test sources.
with "gnatcoll";
project Test is
Test_Sources := External("TEST_SOURCES");
for Source_Dirs use (".", Test_Sources);
for Main use ("test.adb");
for Languages use ("Ada", "C");
for Object_Dir use "obj";
package Compiler is
-- Building test programs in debug mode makes it easier to work with
-- tests.
for Switches ("Ada") use
("-g", "-O1", "-gnata", "-gnatyg", "-gnateE",
"-gnatwaCJe", "-fstack-check", "-gnatw.P");
for Switches ("C") use ("-g", "-Wunreachable-code");
end Compiler;
end Test;
gnatcoll-core-21.0.0/testsuite/support/test_assert.ads 0000644 0001750 0001750 00000010754 13661715457 023011 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2018-2019, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
-- Helper package to implement tests that comply with the expectations
-- of the default test driver.
with Ada.Strings.UTF_Encoding;
with Ada.Calendar; use Ada.Calendar;
with GNAT.Source_Info;
with GNATCOLL.VFS;
package Test_Assert is
package SI renames GNAT.Source_Info;
package VFS renames GNATCOLL.VFS;
package UTF8 renames Ada.Strings.UTF_Encoding;
Final_Status : Natural := 0;
procedure Assert
(Success : Boolean;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Success is True then test case is considered PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
procedure Assert
(Left, Right : String;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Left = Right then test case is considered PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
procedure Assert
(Left : Wide_String;
Right : UTF8.UTF_8_String;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Left = Right then test case is considered PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
procedure Assert_Inferior
(Left : Time;
Right : Time;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Left <= Right then test case is considred PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
procedure Assert
(Left : Integer;
Right : Integer;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Left = Right then test case is considered PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
procedure Assert
(Left, Right : VFS.Virtual_File;
Msg : String := "";
Location : String := SI.Source_Location);
-- If Left = Right then test case is considered PASSED, otherwise
-- the test status is FAILED and Final_Status set to 1.
Assert_Count : Natural := 0;
-- Incremented every time an assert is called. Can be checked against a
-- specific value to verify that the expected number of Asserts triggered,
-- when their number depends on execution, e.g. if they are called from
-- inside callbacks or conditional branches.
function Report return Natural;
-- Report should be called the following way at the end of a test
-- program main function:
--
-- return Report;
--
-- Testsuite driver will consider a test to PASS if all the
-- following conditions are met:
--
-- * test program exit with status 0
-- * all assert calls did succeed
-- * test program display the message "<=== TEST PASSED ===>"
end Test_Assert;
gnatcoll-core-21.0.0/testsuite/support/test_assert.adb 0000644 0001750 0001750 00000015033 13661715457 022763 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2018-2019, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Strings.UTF_Encoding.Wide_Strings;
with Ada.Calendar.Conversions; use Ada.Calendar.Conversions;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
package body Test_Assert is
package IO renames Ada.Text_IO;
package UTF renames Ada.Strings.UTF_Encoding.Wide_Strings;
procedure Put_Indented (Indent_Columns : Natural; Lines : String);
-- Put Lines on the standard output. This also indents all but the first
-- line with Indent_Column spaces.
------------
-- Assert --
------------
procedure Assert
(Success : Boolean;
Msg : String := "";
Location : String := SI.Source_Location) is
begin
-- Start with an indicator about test status so that it is easy to
-- quickly spot failing tests.
if Success then
IO.Put ("OK ");
else
IO.Put ("FAIL");
Final_Status := 1;
end if;
-- Then tell where the failure happened, and add the given message (if
-- any).
IO.Put (" " & Location);
if Msg'Length > 0 then
IO.Put (" " & Msg);
end if;
IO.New_Line;
Assert_Count := Assert_Count + 1;
end Assert;
------------------
-- Put_Indented --
------------------
procedure Put_Indented (Indent_Columns : Natural; Lines : String) is
Starting_Line : Boolean := False;
begin
for C of Lines loop
if C = ASCII.LF then
Starting_Line := True;
elsif Starting_Line then
Starting_Line := False;
IO.Put ((1 .. Indent_Columns => ' '));
end if;
IO.Put (C);
end loop;
end Put_Indented;
------------
-- Assert --
------------
procedure Assert
(Left, Right : String;
Msg : String := "";
Location : String := SI.Source_Location)
is
Success : constant Boolean := Left = Right;
Expected_Prefix : constant String := "expected: ";
Got_Prefix : constant String := "got: ";
Indent : constant Natural := Expected_Prefix'Length;
begin
Assert (Success, Msg, Location);
if not Success then
if Right'Length > 0 then
IO.Put (Expected_Prefix);
Put_Indented (Indent, Right);
IO.New_Line;
else
IO.Put_Line ("expected empty string");
end if;
if Left'Length > 0 then
IO.Put (Got_Prefix);
Put_Indented (Indent, Left);
IO.New_Line;
else
IO.Put_Line ("got empty string");
end if;
end if;
end Assert;
------------
-- Assert --
------------
procedure Assert
(Left : Wide_String;
Right : UTF8.UTF_8_String;
Msg : String := "";
Location : String := SI.Source_Location)
is
UTF_Left : constant UTF8.UTF_8_String := UTF.Encode (Left);
begin
Assert (UTF_Left, Right, Msg, Location);
end Assert;
------------
-- Assert --
------------
procedure Assert
(Left : Integer;
Right : Integer;
Msg : String := "";
Location : String := SI.Source_Location)
is
Success : constant Boolean := Left = Right;
begin
Assert (Success, Msg, Location);
if not Success then
IO.Put_Line ("expected: " & Right'Img);
IO.Put_Line ("got: " & Left'Img);
end if;
end Assert;
------------
-- Assert --
------------
procedure Assert
(Left, Right : VFS.Virtual_File;
Msg : String := "";
Location : String := SI.Source_Location)
is
use type VFS.Virtual_File;
Success : constant Boolean := Left = Right;
begin
Assert (Success, Msg, Location);
if not Success then
IO.Put_Line ("expected: " & VFS.Display_Full_Name (Right));
IO.Put_Line ("got: " & VFS.Display_Full_Name (Left));
end if;
end Assert;
---------------------
-- Assert_Inferior --
---------------------
procedure Assert_Inferior
(Left : Time;
Right : Time;
Msg : String := "";
Location : String := SI.Source_Location)
is
Success : constant Boolean := Left < Right;
begin
Assert (Success, Msg, Location);
if not Success then
IO.Put_Line ("left: " & Image (Left) &
" (" & To_Unix_Nano_Time (Left)'Img & ")");
IO.Put_Line ("right: " & Image (Right) &
" (" & To_Unix_Nano_Time (Right)'Img & ")");
end if;
end Assert_Inferior;
------------
-- Report --
------------
function Report return Natural is
begin
if Final_Status = 0 then
IO.Put_Line ("<=== TEST PASSED ===>");
else
IO.Put_Line ("<=== TEST FAILED ===>");
end if;
return Final_Status;
end Report;
end Test_Assert;
gnatcoll-core-21.0.0/testsuite/tests/ 0000755 0001750 0001750 00000000000 13661715457 017377 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/ 0000755 0001750 0001750 00000000000 13661715457 020537 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/add_search_path/ 0000755 0001750 0001750 00000000000 13743647711 023626 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/add_search_path/test.adb 0000644 0001750 0001750 00000002224 13661715457 025257 0 ustar nicolas nicolas with GNATCOLL.Utils;
with Test_Assert;
with Ada.Environment_Variables;
with GNAT.OS_Lib;
function Test return Integer is
package GU renames GNATCOLL.Utils;
package A renames Test_Assert;
package Env renames Ada.Environment_Variables;
package OS renames GNAT.OS_Lib;
Sep : constant Character := OS.Path_Separator;
begin
Env.Clear ("GNATCOLL_PATH");
GU.Add_Search_Path ("GNATCOLL_PATH", "/dummy");
A.Assert (Env.Value ("GNATCOLL_PATH", ""), "/dummy");
GU.Add_Search_Path ("GNATCOLL_PATH", "/dummy2");
A.Assert (Env.Value ("GNATCOLL_PATH", ""),
"/dummy2" & OS.Path_Separator & "/dummy");
GU.Add_Search_Path ("GNATCOLL_PATH", "/dummy");
A.Assert (Env.Value ("GNATCOLL_PATH", ""),
"/dummy" & OS.Path_Separator & "/dummy2");
Env.Set ("GNATCOLL_PATH", "." & Sep & Sep);
GU.Add_Search_Path ("GNATCOLL_PATH", "/dummy");
A.Assert (Env.Value ("GNATCOLL_PATH", ""),
"/dummy" & OS.Path_Separator & "." & Sep & Sep);
GU.Add_Search_Path ("GNATCOLL_PATH", "");
A.Assert (Env.Value ("GNATCOLL_PATH", ""),
"/dummy" & OS.Path_Separator & "." & Sep & Sep);
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/add_search_path/test.yaml 0000644 0001750 0001750 00000000160 13743647711 025466 0 ustar nicolas nicolas title: GNATCOLL.Utils.Add_Search_Path
control:
- [XFAIL, "env.valgrind", "Known memory leak: see S912-005"]
gnatcoll-core-21.0.0/testsuite/tests/utils/str_checks/ 0000755 0001750 0001750 00000000000 13661715457 022667 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/str_checks/test.adb 0000644 0001750 0001750 00000011334 13661715457 024320 0 ustar nicolas nicolas with GNATCOLL.Utils;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Test_Assert;
with Ada.Text_IO;
function Test return Integer is
package A renames Test_Assert;
package IO renames Ada.Text_IO;
procedure Test_Equality;
procedure Test_Is_Whitespace;
procedure Test_Starts_With;
procedure Test_Ends_With;
procedure Test_Is_Blank_Line;
procedure Test_Equality is
S1 : constant String := "abcdefg";
S2 : constant String := To_Upper (S1);
S3 : constant String := "hijklmn";
S4 : constant String := S1 & S3;
Empty : constant String := "";
begin
for CS in Boolean loop
IO.Put_Line ("Test Equal with case sensitity set to: " & CS'Image);
A.Assert (GNATCOLL.Utils.Equal (Empty, "", Case_Sensitive => CS)
= True,
Msg => "empty string");
A.Assert (GNATCOLL.Utils.Equal (S1, S1, Case_Sensitive => CS)
= True,
Msg => "exact same string");
A.Assert (GNATCOLL.Utils.Equal (S1, S2, Case_Sensitive => CS)
= not CS,
Msg => "compare to To_Upper copy");
A.Assert (GNATCOLL.Utils.Equal (S1, S3, Case_Sensitive => CS)
= False,
Msg => "differnet strings");
A.Assert (GNATCOLL.Utils.Equal (S4, S1, Case_Sensitive => CS)
= False,
Msg => "S4 compare to its substring S1");
end loop;
IO.Put_Line ("Test Case_Insensitive_Equal");
A.Assert (GNATCOLL.Utils.Case_Insensitive_Equal (S1, S1) = True,
Msg => "exact same string");
A.Assert (GNATCOLL.Utils.Case_Insensitive_Equal (S1, S2) = True,
Msg => "compare to To_Upper copy");
A.Assert (GNATCOLL.Utils.Case_Insensitive_Equal (S1, S3) = False,
Msg => "different string");
end Test_Equality;
procedure Test_Is_Whitespace is
subtype Whitespace_Type is Character with
Static_Predicate => Whitespace_Type in ' ' | LF | CR;
begin
IO.Put_Line ("Test Is_Whitespace");
for Car in Whitespace_Type loop
A.Assert (GNATCOLL.Utils.Is_Whitespace (Car) = True,
Msg => Character'Image (Car) & " is whitespace");
end loop;
A.Assert (GNATCOLL.Utils.Is_Whitespace ('a') = False,
Msg => "is whitespace false");
A.Assert (GNATCOLL.Utils.Is_Whitespace (NUL) = False,
Msg => "is whitespace empty");
end Test_Is_Whitespace;
procedure Test_Starts_With is
begin
IO.Put_Line ("Test Starts_With");
A.Assert (GNATCOLL.Utils.Starts_With ("ABCD", "ABC") = True,
Msg => "starts_with true");
A.Assert (GNATCOLL.Utils.Starts_With ("ABCD", "") = True,
Msg => "starts_with empty => always true");
A.Assert (GNATCOLL.Utils.Starts_With ("ABCD", "BCD") = False,
Msg => "starts_with false");
A.Assert (GNATCOLL.Utils.Starts_With ("ABCD", "BCDEFGH") = False,
Msg => "starts_with false : pattern too long");
end Test_Starts_With;
procedure Test_Ends_With is
begin
IO.Put_Line ("Test Ends_With");
A.Assert (GNATCOLL.Utils.Ends_With ("ABCD", "BCD") = True,
Msg => "ends_with true");
A.Assert (GNATCOLL.Utils.Ends_With ("ABCD", "") = True,
Msg => "ends_with empty => always true");
A.Assert (GNATCOLL.Utils.Ends_With ("ABCD", "ABC") = False,
Msg => "ends_with false");
A.Assert (GNATCOLL.Utils.Ends_With ("ABCD", "ABCDEFG") = False,
Msg => "ends_with false : pattern too long");
end Test_Ends_With;
procedure Test_Is_Blank_Line is
S1 : constant String := " " & ASCII.CR;
S2 : constant String := "AAAAA";
S3 : constant String := S1 & ASCII.CR & ASCII.LF & S2;
begin
IO.Put_Line ("Test Is_Blank_Line");
A.Assert (GNATCOLL.Utils.Is_Blank_Line ("", 0) = True,
Msg => "empty string and Index = 0");
A.Assert (GNATCOLL.Utils.Is_Blank_Line (S1, 0) = True,
Msg => "only blank + Index = 0");
A.Assert (GNATCOLL.Utils.Is_Blank_Line (S2, 0) = False,
Msg => "Not blank + Index = 0");
A.Assert (GNATCOLL.Utils.Is_Blank_Line ("", 5) = True,
Msg => "empty string, Index > 0");
A.Assert (GNATCOLL.Utils.Is_Blank_Line (S3, S1'Length + 3) = False,
Msg => "not blank");
end Test_Is_Blank_Line;
begin
IO.New_Line;
Test_Equality;
IO.New_Line;
Test_Is_Whitespace;
IO.New_Line;
Test_Starts_With;
IO.New_Line;
Test_Ends_With;
IO.New_Line;
Test_Is_Blank_Line;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/str_checks/test.yaml 0000644 0001750 0001750 00000000362 13661715457 024533 0 ustar nicolas nicolas title: "GNATCOLL.Utils string checks"
description: >
"Test of checks on Strings available in GNATCOLL.Utils. Only involves
String type, and no modifications of the String in entry, handle the whole
string or character (no split)"
gnatcoll-core-21.0.0/testsuite/tests/utils/str_proc/ 0000755 0001750 0001750 00000000000 13661715457 022372 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/str_proc/test.adb 0000644 0001750 0001750 00000011526 13661715457 024026 0 ustar nicolas nicolas with GNATCOLL.Utils;
with GNAT.Strings;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with System.Assertions;
with Test_Assert;
with Ada.Text_IO;
function Test return Integer is
package A renames Test_Assert;
package IO renames Ada.Text_IO;
procedure Test_Replace;
procedure Test_Capitalize;
procedure Test_Join;
procedure Test_Replace is
S : constant String :=
"This adacore is adacore a adacore String";
SS : constant String :=
"This something is something a something String";
S2 : Unbounded_String := To_Unbounded_String (S);
S3 : constant String := "This is a String";
begin
-- Test Replace with String --
IO.Put_Line ("Test Replace with Strings");
declare
S4 : constant String := GNATCOLL.Utils.Replace (S, "adacore ", "");
S5 : constant String := GNATCOLL.Utils.Replace
(S, "adacore", "something");
S6 : constant String := GNATCOLL.Utils.Replace (S, "something",
"something_else");
begin
A.Assert (S4 = S3, Msg => "replace valid pattern into empty string");
A.Assert (S5 = SS, Msg => "replace valid pattern");
A.Assert (S6 = S, Msg => "replace 'absent' pattern into other word");
declare
pragma Warnings (Off);
S7 : String (1 .. S'Length);
pragma Warning (On);
begin
S7 := GNATCOLL.Utils.Replace (S, "", " something");
A.Assert (False,
Msg => "replace failed raising exception or pre-cond");
exception
when System.Assertions.Assert_Failure =>
A.Assert (True,
Msg => "replace raised assertion failure");
when Ada.Strings.Pattern_Error =>
A.Assert (True,
Msg => "replace raised exception (no assertions)");
end;
end;
-- Test Replace with Unbounded String --
IO.Put_Line ("Test Replace with Unbounded Strings");
GNATCOLL.Utils.Replace (S2, "adacore ", "");
A.Assert (To_String (S2) = S3,
Msg => "replace valid pattern into empty string");
GNATCOLL.Utils.Replace (S2, "something", "something_else");
A.Assert (To_String (S2) = S3,
Msg => "replace valid pattern");
declare
begin
GNATCOLL.Utils.Replace (S2, "", " something");
A.Assert (False,
Msg => "replace failed raising exception or pre-cond");
exception
when System.Assertions.Assert_Failure =>
A.Assert (True,
Msg => "replace raised assertion failure");
when Ada.Strings.Pattern_Error =>
A.Assert (True,
Msg => "replace raised exception (no assertions)");
end;
end Test_Replace;
procedure Test_Capitalize is
S1 : constant String := "abcdefg";
S2 : constant String := To_Upper (S1);
S3 : constant String := "Abcdefg";
Empty : constant String := "";
begin
IO.Put_Line ("Test Capitalize");
A.Assert (GNATCOLL.Utils.Capitalize (Empty) = "",
Msg => "empty string");
A.Assert (GNATCOLL.Utils.Capitalize (S1) = S3,
Msg => "capitalize from all lower");
A.Assert (GNATCOLL.Utils.Capitalize (S2) = S3,
Msg => "capitalize from all upper");
A.Assert (GNATCOLL.Utils.Capitalize ("abCD__ef___GHi_j_k__l")
= "Abcd_Ef_Ghi_J_K_L",
Msg => "capitalize when several '_'");
A.Assert (GNATCOLL.Utils.Capitalize ("abCD/ef//GHi/j/k////l")
= "Abcd_Ef__Ghi_J_K____L",
Msg => "capitalize when several '/'");
A.Assert (GNATCOLL.Utils.Capitalize ("c++abcd") = "Cppabcd",
Msg => "capitalize with '+'");
A.Assert (GNATCOLL.Utils.Capitalize ("c--abcd") = "C__Abcd",
Msg => "capitalize with '-'");
A.Assert (GNATCOLL.Utils.Capitalize ("abc'def''ghijkl'''mno")
= "Abc_Def__Ghijkl___Mno",
Msg => "capitalize with ");
A.Assert (GNATCOLL.Utils.Capitalize ("\abc?def?\?g\hijkl???mno")
= "\abcUdefU\Ug\hijklUUUmno",
Msg => "capitalize with '?' and '\'");
end Test_Capitalize;
procedure Test_Join is
S1 : constant String := ",";
S2 : aliased String := "adacore";
S : constant String := S2 & S1 & S2 & S1 & S2 & S1 & S2 & S1 & S2;
SL : GNAT.Strings.String_List (1 .. 5) :=
(others => S2'Unchecked_Access);
begin
A.Assert (GNATCOLL.Utils.Join (S1, SL) = S,
Msg => "simple join");
end Test_Join;
begin
IO.New_Line;
IO.Put_Line ("GNATCOLL.UTILS");
IO.New_Line;
Test_Replace;
IO.New_Line;
Test_Capitalize;
IO.New_Line;
Test_Join;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/str_proc/test.yaml 0000644 0001750 0001750 00000000146 13661715457 024236 0 ustar nicolas nicolas title: GNATCOLL.Utils strings processing
description: Test for GNATCOLL.Utils processing of string
gnatcoll-core-21.0.0/testsuite/tests/utils/str_query/ 0000755 0001750 0001750 00000000000 13661715457 022574 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/str_query/test.adb 0000644 0001750 0001750 00000027422 13661715457 024232 0 ustar nicolas nicolas with GNATCOLL.Utils;
with Test_Assert;
with Ada.Text_IO;
function Test return Integer is
package A renames Test_Assert;
package IO renames Ada.Text_IO;
procedure Test_Image;
procedure Test_Find_Char;
procedure Test_Line_Start;
procedure Test_Next_Line;
procedure Test_Line_End;
procedure Test_Previous_Line;
procedure Test_Image is
S1 : constant String := "005";
S2 : constant String := '+' & S1;
S3 : constant String := "-00000" & S1;
Int1 : constant Integer := 5;
Int2 : constant Integer := -5;
S4 : constant String := "- 455";
Int3 : constant Integer := -455;
begin
IO.Put_Line ("Test Image");
A.Assert (GNATCOLL.Utils.Image (Int1,
Int1'Image'Length,
Padding => ' ') = Int1'Image,
Msg => "positive, mimic attribute Image");
A.Assert (GNATCOLL.Utils.Image (Int1, S1'Length) = S1,
Msg => "positive, several 0 (default padding)");
A.Assert (GNATCOLL.Utils.Image (Int1,
S1'Length,
Force_Sign => True) = S2,
Msg => "positive, several 0, force sign");
A.Assert (GNATCOLL.Utils.Image (Int2,
S3'Length - 1) = S3,
Msg => "negative, several 0");
A.Assert (GNATCOLL.Utils.Image (Int3,
S4'Length - 1,
Padding => ' ',
Force_Sign => True) = S4,
Msg => "negative, several ' ', force sign");
end Test_Image;
procedure Test_Find_Char is
Str : String (1 .. Character'Pos (Character'Last) + 1);
Str2 : constant String := "AAAAAAAAAAAAAAAAAAA";
Str3 : constant String := Str2 & ASCII.LF & "BBBBB";
begin
IO.Put_Line ("Test Find_Char");
for Char in Character loop
Str (Character'Pos (Char) + 1) := Char;
end loop;
for Char in Character loop
A.Assert (GNATCOLL.Utils.Find_Char (Str, Char) =
Character'Pos (Char) + 1,
Msg => "find all char in in all char string");
end loop;
A.Assert (GNATCOLL.Utils.Find_Char (Str2, 'B') = Str2'Last + 1,
Msg => "not found");
A.Assert (GNATCOLL.Utils.Find_Char (Str2, 'A') = Str2'First,
Msg => "several occurence => take first");
A.Assert (GNATCOLL.Utils.Find_Char ("", 'A') = 1,
Msg => "in empty string = found at begining");
A.Assert (GNATCOLL.Utils.Find_Char (Str2, ASCII.NUL)
= Str2'Last + 1,
Msg => "null char in string = not found");
IO.Put_Line ("Test EOL");
A.Assert (GNATCOLL.Utils.EOL (Str2) = Str2'Last + 1,
Msg => "EOL not found");
A.Assert (GNATCOLL.Utils.EOL (Str3) = Str2'Length + 1,
Msg => "first occurence of EOL");
A.Assert (GNATCOLL.Utils.EOL ("") = 1,
Msg => "EOL in empty string");
end Test_Find_Char;
procedure Test_Line_Start is
S1 : constant String := "This is line 1";
S2 : constant String := "This is the second line";
CRLF : constant String := ASCII.CR & ASCII.LF;
LFCR : constant String := ASCII.LF & ASCII.CR;
S_1LF : constant String := S1 & ASCII.LF & S2;
S_1CR : constant String := S1 & ASCII.CR & S2;
S_6LF : constant String := S1 & ASCII.LF & ASCII.LF
& ASCII.LF & ASCII.LF & ASCII.LF & ASCII.LF & S2;
S_6CR : constant String := S1 & ASCII.CR & ASCII.CR
& ASCII.CR & ASCII.CR & ASCII.CR & ASCII.CR & S2;
S_6CRLF : constant String := S1 & CRLF & CRLF & CRLF & CRLF & CRLF
& CRLF & S2;
S_6LFCR : constant String := S1 & LFCR & LFCR & LFCR & LFCR & LFCR
& LFCR & S2;
begin
IO.Put_Line ("Test Line_Start");
A.Assert (GNATCOLL.Utils.Line_Start (S1, 0) = 0,
Msg => "P equals 0 (under S1 lower bound)");
A.Assert (GNATCOLL.Utils.Line_Start (S1, S1'Last + 100) = 1,
Msg => "P over S1 upper bound");
A.Assert (GNATCOLL.Utils.Line_Start (S1, 1) = 1,
Msg => "P on first char");
A.Assert (GNATCOLL.Utils.Line_Start (S1, S1'Last) = 1,
Msg => "one line, P on last char");
A.Assert (GNATCOLL.Utils.Line_Start (S1, S1'Length - 2) = 1,
Msg => "one line, P in string");
A.Assert (GNATCOLL.Utils.Line_Start (S_1LF, S1'Length) = 1,
Msg => "P is before an LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_1LF, S1'Length + 2) =
S1'Length + 2,
Msg => "P is after an LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_1LF, S1'Length + 1) = 1,
Msg => "P is on a LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_6LF, S1'Length + 6) =
S1'Length + 6,
Msg => "P is on 6th LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_6LF, S1'Length + 7) =
S1'Length + 7,
Msg => "P is after last LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_1CR, S1'Length) = 1,
Msg => "P is before a CR char (no LF)");
A.Assert (GNATCOLL.Utils.Line_Start (S_1CR, S1'Length + 2) =
S1'Length + 2,
Msg => "P is after a CR char");
A.Assert (GNATCOLL.Utils.Line_Start (S_1CR, S1'Length + 1) = 1,
Msg => "P is on a CR char");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CR, S1'Length + 6) =
S1'Length + 6,
Msg => "P is on 6th CR char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CR, S1'Length + 7) =
S1'Length + 7,
Msg => "P is after last CR char (no CR)");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CRLF, S1'Length + 2) = 1,
Msg => "P on the LF of a CRLF");
A.Assert (GNATCOLL.Utils.Line_Start (S_6LFCR, S1'Length + 2) =
S1'Length + 2,
Msg => "P on the CR of a LFCR");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CRLF, S1'Length + 5) =
S1'Length + 5,
Msg => "P on the CR of the 3rd CRLF");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CRLF, S1'Length + 6) =
S1'Length + 5,
Msg => "P on the LF of the 3rd CRLF");
A.Assert (GNATCOLL.Utils.Line_Start (S_6LFCR, S1'Length + 5) =
S1'Length + 4,
Msg => "P on the LF of the 3rd LFCR");
A.Assert (GNATCOLL.Utils.Line_Start (S_6LFCR, S1'Length + 6) =
S1'Length + 6,
Msg => "P on the CR of the 3rd LFCR");
A.Assert (GNATCOLL.Utils.Line_Start (S_6CRLF, S1'Length + 13) =
S1'Length + 13,
Msg => "P after last CRLF");
A.Assert (GNATCOLL.Utils.Line_Start (CRLF, 2) = CRLF'First,
Msg => "P on the LF of a string only made of 1 CRLF");
A.Assert (GNATCOLL.Utils.Line_Start (LFCR, 2) = CRLF'First + 1,
Msg => "P on the CR of a string only made of 1 LFCR");
end Test_Line_Start;
procedure Test_Next_Line is
S1 : constant String := "This is line 1";
S2 : constant String := "This is the second line";
S3 : constant String := "This is the third line";
CRLF : constant String := ASCII.CR & ASCII.LF;
LFCR : constant String := ASCII.LF & ASCII.CR;
S_CRLF : constant String := S1 & CRLF & S2 & CRLF & S3;
S_LFCR : constant String := S1 & LFCR & S2 & LFCR & S3;
begin
IO.Put_Line ("Test Next_Line");
A.Assert (GNATCOLL.Utils.Next_Line (S1, 0) = S1'Length,
Msg => "P equals 0 (under S1 lower bound)");
A.Assert (GNATCOLL.Utils.Next_Line (S1, S1'Last + 100) = S1'Length,
Msg => "P over S1 upper bound");
A.Assert (GNATCOLL.Utils.Next_Line (S1, S1'Length - 2) = S1'Length,
Msg => "one line, P in string");
A.Assert (GNATCOLL.Utils.Next_Line (S_CRLF, S1'Length + 1) =
S1'Length + 3,
Msg => "P on a CR of a CRLF (string continue after that)");
A.Assert (GNATCOLL.Utils.Next_Line (S_CRLF, S1'Length + 2) =
S1'Length + 3,
Msg => "P on an LF of a CRLF (string continue after that)");
A.Assert (GNATCOLL.Utils.Next_Line (S_LFCR, S1'Length + 1) =
S1'Length + 2,
Msg => "P on a LF of a LFCR (string continues after that)");
A.Assert (GNATCOLL.Utils.Next_Line (S_LFCR, S1'Length + 2) =
S1'Length + 2 + S2'Length + 2,
Msg => "P on a CR of a LFCR (string continues after that)");
end Test_Next_Line;
procedure Test_Previous_Line is
S1 : constant String := "This is line 1";
S2 : constant String := "This is the second line";
S3 : constant String := "This is the third line";
CRLF : constant String := ASCII.CR & ASCII.LF;
LFCR : constant String := ASCII.LF & ASCII.CR;
S_CRLF : constant String := S1 & CRLF & S2 & CRLF & S3;
S_LFCR : constant String := S1 & LFCR & S2 & LFCR & S3;
begin
IO.Put_Line ("Test Previous_Line");
A.Assert (GNATCOLL.Utils.Previous_Line (S1, 0) = 1,
Msg => "P equals 0 (under S1 lower bound)");
A.Assert (GNATCOLL.Utils.Previous_Line (S1, S1'Last + 100) = S1'First,
Msg => "P over S1 upper bound");
A.Assert (GNATCOLL.Utils.Previous_Line (S1, S1'Length - 2) = S1'First,
Msg => "one line, P in string");
A.Assert (GNATCOLL.Utils.Previous_Line (S_CRLF, S1'Length + 5) =
S1'First,
Msg => "In a string, after a CRLF");
A.Assert (GNATCOLL.Utils.Previous_Line (S_LFCR, S1'Length + 5) =
S1'Length + 2,
Msg => "In a string, after a LFCR");
A.Assert (GNATCOLL.Utils.Previous_Line (S_LFCR, S1'Length + 1) =
S1'First,
Msg => "P on a LF of a string with LFCR");
A.Assert (GNATCOLL.Utils.Previous_Line (S_LFCR, S1'Length + 2) =
S1'First,
Msg => "P on a CR of a string with LFCR");
A.Assert (GNATCOLL.Utils.Previous_Line (S_CRLF, S1'Length + 1) =
S1'First,
Msg => "P on a CR of a string with CRLF");
A.Assert (GNATCOLL.Utils.Previous_Line (S_CRLF, S1'Length + 2) =
S1'First,
Msg => "P on an LF of a string with CRLF");
end Test_Previous_Line;
procedure Test_Line_End is
S1 : constant String := "This is line 1";
S2 : constant String := "This is the second line";
CRLF : constant String := ASCII.CR & ASCII.LF;
S_6LF : constant String := S1 & ASCII.LF & ASCII.LF
& ASCII.LF & ASCII.LF & ASCII.LF & ASCII.LF & S2;
S_6CR : constant String := S1 & ASCII.CR & ASCII.CR
& ASCII.CR & ASCII.CR & ASCII.CR & ASCII.CR & S2;
begin
IO.Put_Line ("Test Line_End");
A.Assert (GNATCOLL.Utils.Line_End (S1, 0) = S1'Length,
Msg => "P equals 0 (under S1 lower bound)");
A.Assert (GNATCOLL.Utils.Line_End (S1, S1'Last + 100) = S1'Length,
Msg => "P over S1 upper bound");
A.Assert (GNATCOLL.Utils.Line_End (S_6LF, S1'First + 1) = S1'Length,
Msg => "P is before an LF char (no CR)");
A.Assert (GNATCOLL.Utils.Line_End (S_6CR, S1'First + 1) = S1'Length,
Msg => "P is before an CR char (no LF)");
-- ??? Line_End of "CRLF" on 1st caracter is 0
A.Assert (GNATCOLL.Utils.Line_End (CRLF, 1) = CRLF'First - 1,
Msg => "P is the CR of a CRLF string");
A.Assert (GNATCOLL.Utils.Line_End (CRLF, 2) = 2 - 1,
Msg => "P is the LF of a CRLF string");
end Test_Line_End;
begin
IO.New_Line;
Test_Image;
IO.New_Line;
Test_Find_Char;
IO.New_Line;
Test_Line_Start;
IO.New_Line;
Test_Line_End;
IO.New_Line;
Test_Next_Line;
IO.New_Line;
Test_Previous_Line;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/str_query/test.yaml 0000644 0001750 0001750 00000000342 13661715457 024436 0 ustar nicolas nicolas title: "GNATCOLL.Utils string queries"
description: >
"Test of queries on Strings available in GNATCOLL.Utils. Only involves
String type, and no modifications of the String in entry. Can involve
split of strings."
gnatcoll-core-21.0.0/testsuite/tests/utils/join_path/ 0000755 0001750 0001750 00000000000 13661715457 022512 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/join_path/test.adb 0000644 0001750 0001750 00000001126 13661715457 024141 0 ustar nicolas nicolas with GNATCOLL.Utils;
with Test_Assert;
with GNAT.OS_Lib;
function Test return Integer is
package GU renames GNATCOLL.Utils;
package A renames Test_Assert;
Sep : constant Character := GNAT.OS_Lib.Directory_Separator;
begin
A.Assert (GU.Join_Path ("/dummy", "lib"),
"/dummy" & Sep & "lib");
A.Assert (GU.Join_Path ("/dummy", "/foo", "bin"),
"/foo" & Sep & "bin");
A.Assert (GU.Join_Path ("/foo", "bar1", "bar2", "bar3", "bar4"),
"/foo" & Sep & "bar1" & Sep & "bar2" & Sep &
"bar3" & Sep & "bar4");
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/join_path/test.yaml 0000644 0001750 0001750 00000000040 13661715457 024347 0 ustar nicolas nicolas title: GNATCOLL.Utils.Path_Join
gnatcoll-core-21.0.0/testsuite/tests/utils/executable_path/ 0000755 0001750 0001750 00000000000 13661715457 023674 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/utils/executable_path/test.adb 0000644 0001750 0001750 00000002150 13661715457 025321 0 ustar nicolas nicolas with GNATCOLL.Utils;
with Test_Assert;
with Ada.Environment_Variables;
with Ada.Directories;
with GNAT.OS_Lib;
function Test return Integer is
package A renames Test_Assert;
package GU renames GNATCOLL.Utils;
package Env renames Ada.Environment_Variables;
package Dir renames Ada.Directories;
package OS renames GNAT.OS_Lib;
begin
declare
Exe_Path : constant String := GU.Executable_Path;
Process_Status : Integer;
Success : Boolean;
begin
A.Assert (OS.Is_Regular_File (Exe_Path));
if not OS.Is_Directory ("Bin") then
Dir.Create_Directory ("Bin");
OS.Copy_File (Exe_Path, "Bin", Success, Preserve => OS.Full);
Process_Status := OS.Spawn ("Bin/test", Args => (1 .. 0 => null));
A.Assert (Process_Status = 0);
end if;
Dir.Set_Directory ("..");
Env.Set ("PATH", "");
A.Assert (Exe_Path, GU.Executable_Path,
"Ensure that executable path is not impacted by " &
"environment changes");
A.Assert (OS.Is_Directory (GU.Executable_Location));
end;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/utils/executable_path/test.yaml 0000644 0001750 0001750 00000000046 13661715457 025537 0 ustar nicolas nicolas title: GNATCOLL.Utils.Executable_Path
gnatcoll-core-21.0.0/testsuite/tests/coders/ 0000755 0001750 0001750 00000000000 13661715457 020656 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/coders/test_streams.adb 0000644 0001750 0001750 00000003162 13661715457 024045 0 ustar nicolas nicolas package body Test_Streams is
----------
-- Read --
----------
overriding procedure Read
(Stream : in out Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is
Length : constant Integer :=
Natural'Min (Item'Length, Stream.Buffer.Length - Stream.Position);
Target : String (1 .. Integer'Max (Length, 0));
for Target'Address use Item'Address;
begin
if Target = "" then
Last := Item'First - 1;
return;
end if;
Target := To_String
(Stream.Buffer.Slice
(Stream.Position + 1, Stream.Position + Length));
Stream.Position := Stream.Position + Length;
Last := Item'First + Stream_Element_Offset (Length) - 1;
end Read;
-----------
-- Write --
-----------
overriding procedure Write
(Stream : in out Stream_Type;
Item : Stream_Element_Array)
is
Source : String (1 .. Item'Length);
for Source'Address use Item'Address;
begin
Stream.Buffer.Append (Source);
end Write;
-----------
-- Clear --
-----------
procedure Clear (Stream : in out Stream_Type) is
begin
Stream.Buffer.Clear;
Stream.Reset;
end Clear;
-----------
-- Reset --
-----------
procedure Reset (Stream : in out Stream_Type) is
begin
Stream.Position := 0;
end Reset;
-----------
-- Slice --
-----------
function Slice
(Stream : Stream_Type; Low : Positive; High : Natural) return String is
begin
return To_String (Stream.Buffer.Slice (Low, High));
end Slice;
end Test_Streams;
gnatcoll-core-21.0.0/testsuite/tests/coders/test.adb 0000644 0001750 0001750 00000012501 13661715457 022304 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
--
-- Test for GNATCOLL.Coders
with Ada.Streams; use Ada.Streams;
with GNATCOLL.Coders.Streams; use GNATCOLL.Coders;
with GNATCOLL.Coders.Base64;
with Tb64;
with Test_Streams;
with Test_Assert;
function Test return Integer is
package A renames Test_Assert;
Stream : aliased Streams.Stream_Type;
Encoder : aliased Base64.Encoder_Type;
Decoder : aliased Base64.Decoder_Type;
Buffer : Stream_Element_Array (0 .. 511);
function Test_Iteration
(Read_Ends_By : Streams.End_Of_Input_Method;
Tail : Stream_Element_Offset) return Boolean;
function Test_Iteration
(Read_Ends_By : Streams.End_Of_Input_Method;
Tail : Stream_Element_Offset) return Boolean
is
subtype Middle_Range is Stream_Element_Offset range 241 .. 270;
TS : aliased Test_Streams.Stream_Type;
Last : Stream_Element_Offset;
begin
Encoder.Initialize (Wrap => 76);
Decoder.Initialize;
Stream.Initialize
(Read_Coder => Decoder'Unchecked_Access,
Write_Coder => Encoder'Unchecked_Access,
Read_From => TS'Unchecked_Access,
Write_To => TS'Unchecked_Access,
Read_Ends_By => Read_Ends_By);
for M in Middle_Range loop
Stream.Write (Buffer (Buffer'First .. M));
Stream.Write (Buffer (M + 1 .. Buffer'Last));
end loop;
Stream.Write (Buffer (Buffer'First .. Tail));
Stream.Flush (Finish);
declare
Result : Stream_Element_Array (Buffer'Range);
begin
for M in reverse Middle_Range loop
Stream.Read (Result (Result'First .. M), Last);
if Last /= M then
A.Assert (False, "Unexpected" & Last'Img & " /= " & M'Img);
return False;
end if;
Stream.Read (Result (M + 1 .. Result'Last), Last);
if Last /= Buffer'Last then
A.Assert
(False,
"Unexpected" & Last'Img & " /= " & Buffer'Last'Img & " at"
& M'Img);
return False;
end if;
if Result (Buffer'Range) /= Buffer then
A.Assert
(False, "Result (Buffer'Range) /= Buffer at " & M'Img & ' '
& TS.Slice (1, 64));
for J in Buffer'Range loop
if Result (J) /= Buffer (J) then
A.Assert
(Result (J)'Img, Buffer (J)'Img, "at index " & J'Img);
return False;
end if;
end loop;
return False;
end if;
end loop;
Stream.Read (Result, Last);
if Last /= Tail then
A.Assert (False, "Unexpected" & Last'Img & " /= " & Tail'Img);
return False;
end if;
if Result (Result'First .. Tail) /= Buffer (Buffer'First .. Tail) then
A.Assert (False, "Tail failure");
for J in Result'First .. Tail loop
if Result (J) /= Buffer (J) then
A.Assert
(Result (J)'Img, Buffer (J)'Img, "at index " & J'Img);
return False;
end if;
end loop;
return False;
end if;
end;
return True;
end Test_Iteration;
begin
for J in Buffer'Range loop
Buffer (J) := Stream_Element'Mod (J);
end loop;
Main_Loop : for End_Mode in Streams.End_Of_Input_Method loop
for Tail in Stream_Element_Offset range 1 .. 255 loop
exit Main_Loop when not Test_Iteration (End_Mode, Tail);
end loop;
end loop Main_Loop;
Tb64;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/coders/test.yaml 0000644 0001750 0001750 00000000046 13661715457 022521 0 ustar nicolas nicolas description: Test for GNATCOLL.Coders
gnatcoll-core-21.0.0/testsuite/tests/coders/test.gpr 0000644 0001750 0001750 00000000612 13661715457 022346 0 ustar nicolas nicolas with "gnatcoll";
project Test is
for Main use ("test.adb");
for Source_Dirs use (".", "../../support");
for Object_Dir use "obj";
package Compiler is
for Switches ("Ada") use ("-g", "-gnateE");
end Compiler;
package Linker is
for Switches ("Ada") use ("-g");
end Linker;
package Binder is
for Switches ("Ada") use ("-E");
end Binder;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/coders/tb64.adb 0000644 0001750 0001750 00000010511 13661715457 022103 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2019, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
--
-- Test base64 encoder and decoder
with Ada.Streams; use Ada.Streams;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.Coders.Base64; use GNATCOLL.Coders;
with GNATCOLL.Email.Utils; use GNATCOLL.Email.Utils;
with Test_Assert;
with GNAT.Random_Numbers; use GNAT.Random_Numbers;
procedure TB64 is
package A renames Test_Assert;
Encoder : Base64.Encoder_Type;
Decoder : Base64.Decoder_Type;
Sample : Stream_Element_Array (1 .. 4096);
Text : String (1 .. Sample'Length);
for Text'Address use Sample'Address;
Coded : Stream_Element_Array (1 .. Sample'Last * 5 / 3 + 1);
Coded_S : String (1 .. Coded'Length);
for Coded_S'Address use Coded'Address;
Coded_U : Unbounded_String;
Result : Stream_Element_Array (Sample'First .. Sample'Last + 1);
Result_U : Unbounded_String;
In_Last : Stream_Element_Offset;
Cod_Last : Stream_Element_Offset;
Res_Last : Stream_Element_Offset;
Gen : Generator;
Printable : constant Boolean := False;
begin
Reset (Gen);
Coded (1) := Stream_Element'Val (Character'Pos ('a'));
for J in Sample'Range loop
if Printable then
Sample (1 .. J) := Coded (1 .. J);
else
Sample (J) := Stream_Element
(Stream_Element'Mod (Integer'(Random (Gen))));
end if;
Encoder.Initialize
(Wrap => (if Integer'(Random (Gen)) rem 8 = 0 then 0
else Random (Gen) rem 70 + 20),
Mode => Base64.Base64_Mode'Val
(Integer'(Random (Gen))
rem (Base64.Base64_Mode'Pos (Base64.Base64_Mode'Last) + 1)));
Decoder.Initialize;
Encoder.Transcode
(In_Data => Sample (1 .. J),
In_Last => In_Last,
Out_Data => Coded,
Out_Last => Cod_Last,
Flush => Finish);
A.Assert (In_Last = J, "In_Last /= J");
Decoder.Transcode
(In_Data => Coded (1 .. Cod_Last),
In_Last => In_Last,
Out_Data => Result,
Out_Last => Res_Last,
Flush => Finish);
A.Assert (In_Last = Cod_Last, "In_Last /= Cod_Last");
A.Assert (J = Res_Last, "J /= Res_Last");
A.Assert (Sample (1 .. J) = Result (1 .. J), "Sample /= Result");
Encoder.Close;
Decoder.Close;
Base64_Encode
(Text (1 .. Integer (J)), "",
Max_Block_Len => Random (Gen) rem 64 + 16,
Result => Coded_U);
Base64_Decode (To_String (Coded_U), Result_U);
A.Assert
(Result_U = Text (1 .. Integer (J)),
"Result_U /= Text (1 .. Integer (J))");
end loop;
end TB64;
gnatcoll-core-21.0.0/testsuite/tests/coders/test_streams.ads 0000644 0001750 0001750 00000001663 13661715457 024072 0 ustar nicolas nicolas with Ada.Streams; use Ada.Streams;
with GNATCOLL.Strings; use GNATCOLL.Strings;
package Test_Streams is
type Stream_Type is new Root_Stream_Type with private;
-- Stream reading the data which was wrote there before
overriding procedure Read
(Stream : in out Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
overriding procedure Write
(Stream : in out Stream_Type;
Item : Stream_Element_Array);
procedure Reset (Stream : in out Stream_Type);
-- Reset read opsition to the start of data
procedure Clear (Stream : in out Stream_Type);
-- Clear all internal written data from stream
function Slice
(Stream : Stream_Type; Low : Positive; High : Natural) return String;
private
type Stream_Type is new Root_Stream_Type with record
Position : Natural := 0;
Buffer : XString;
end record;
end Test_Streams;
gnatcoll-core-21.0.0/testsuite/tests/config/ 0000755 0001750 0001750 00000000000 13661715457 020644 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/config/test_as.ini 0000644 0001750 0001750 00000000047 13661715457 023010 0 ustar nicolas nicolas file=test1.ini
dir=..
bool=true
int=15
gnatcoll-core-21.0.0/testsuite/tests/config/test2.ini 0000644 0001750 0001750 00000000010 13661715457 022375 0 ustar nicolas nicolas invalid
gnatcoll-core-21.0.0/testsuite/tests/config/test1.ini 0000644 0001750 0001750 00000000321 13661715457 022401 0 ustar nicolas nicolas key1=value1
section1.key2 = value2_no_section
int1 = 1
bool1=true
bool2=False
[section1]
key2 = value2
key3 =value 3
# This is a comment =
key4=value4
# This is another comment
key[5=value5
[key6=value6
gnatcoll-core-21.0.0/testsuite/tests/config/test5.ini 0000644 0001750 0001750 00000000132 13661715457 022405 0 ustar nicolas nicolas #comment=key
key5_1 = value
[section5_1]
key5_1 = value2
[sec#tion]
key5_2 = value3
gnatcoll-core-21.0.0/testsuite/tests/config/test.adb 0000644 0001750 0001750 00000016126 13661715457 022301 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2010-2018, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Directories;
with GNATCOLL.Config;
with Test_Assert;
function Test return Integer is
package IO renames Ada.Text_IO;
package Dir renames Ada.Directories;
package A renames Test_Assert;
package Cfg renames GNATCOLL.Config;
Ini : Cfg.INI_Parser;
Ini2 : Cfg.INI_Parser;
Ini3 : Cfg.INI_Parser;
Sys : Cfg.INI_Parser;
Pool : Cfg.Config_Pool;
begin
-- Open non existing file
begin
Ini.Open ("non_existent.ini");
A.Assert (False, "Name_Error should be raised");
exception
when IO.Name_Error =>
A.Assert (True, "Name_Error raised if ini file does not exist");
when others =>
A.Assert (False, "Name_Error should have been raised");
end;
-- Open a simple file
IO.Put_Line ("Loading test1.ini");
Ini.Open ("test1.ini");
Pool.Fill (Ini);
A.Assert (Pool.Get ("key1"), "value1", "check that key1=value1");
A.Assert (Pool.Get ("key2", Section => "section1"), "value2",
"check that key2=value2 in section1");
A.Assert (Pool.Get ("key3", Section => "section1"), "value 3",
"check that trailing spaces are ignored");
A.Assert (Pool.Get ("section1.key2",
Section => Cfg.Section_From_Key),
"value2",
"check that sections1.key2=value2 (dot notation)");
A.Assert (Pool.Get ("section1.key4"),
"value4",
"check that comments around key " &
"declaration do not have impacts");
A.Assert (Pool.Get ("section1.key[5"),
"value5",
"key can contain [");
A.Assert (Pool.Get ("section1.[key6"),
"value6",
"key can start with [");
-- Try to read invalid file (parser is very laxist and does not crash)
Ini.Open ("test2.ini");
Pool.Fill (Ini);
A.Assert (Pool.Get ("key1"), "value1", "check if key1=value1 is preserved");
A.Assert (Pool.Get ("invalid"), "", "check if invalid key exist");
-- Check if we can override values.
-- The test reuse the same INI_Parser instance and thus check that on
-- call to Open parser state is reset
IO.Put_Line ("Loading test3.ini (parser reuse)");
Ini.Open ("test3.ini");
Pool.Fill (Ini);
A.Assert (Pool.Get ("key1"), "value1_2",
"check if key1 is overwritten");
A.Assert (Pool.Get ("key7"), "value7", "check addition of new key key7");
A.Assert (Pool.Get ("section1.key2"),
"value2", "check if section1.key2=value2 is preserved");
-- Check if we can override values
-- Use a new parser instance
IO.Put_Line ("Loading test3.ini (new parser)");
Ini2.Open ("test3.ini");
Pool.Fill (Ini2);
A.Assert (Pool.Get ("key1"), "value1_2",
"check if key1 value is overwritten");
A.Assert (Pool.Get ("key7"), "value7", "check addtion of new key key7");
A.Assert (Pool.Get ("section1.key2"),
"value2", "check if section1.key2=value2 is preserved");
-- Test non string values
A.Assert (Pool.Get_Boolean ("bool1"), "boolean value (true)");
A.Assert (not Pool.Get_Boolean ("bool2"), "boolean value (false)");
A.Assert (Pool.Get_Integer ("int1") = 1, "integer value");
-- Test Config_Key creation
declare
CK1 : constant Cfg.Config_Key := Cfg.Create ("key1");
begin
A.Assert (CK1.Get (Pool), "value1_2", "basic config_key test");
end;
-- Check that introducing invalid gnatcoll templates strings do
-- not crash the parser.
IO.Put_Line ("Loading test4.ini (crashing the gnatcoll-template)");
begin
Ini3.Open ("test4.ini");
Pool.Fill (Ini3);
A.Assert (True, "parsing test4.ini");
exception
when others =>
A.Assert (False, "parsing test4.ini");
end;
-- Check some corner cases involving leading whitespaces for example
IO.Put_Line ("Loading test5.ini");
begin
Ini3.Open ("test5.ini");
Pool.Fill (Ini3);
A.Assert (True, "parsing test5.ini");
A.Assert (Pool.Get ("#comment") /= "key",
"ensure comment was parsed correctly");
A.Assert (Pool.Get ("key5_1") /= "value2",
"ensure section was parsed correctly");
A.Assert (Pool.Get ("tion#key5_2", Section => "sec") /= "value3",
"ensure # is not considered as a special character");
exception
when others =>
A.Assert (False, "parsing test5.ini");
end;
-- Check that a line containing only [ will not crash the parser
begin
Ini3.Open ("test6.ini");
Pool.Fill (Ini3);
A.Assert (True, "parsing test6.ini");
exception
when others =>
A.Assert (False, "parsing test6.ini");
end;
-- Check system_id related functionality
IO.Put_Line ("Loading test_sys.ini");
Sys.Set_System_Id (Dir.Current_Directory);
Sys.Open ("test_as.ini");
A.Assert (Sys.As_Absolute_File, Dir.Full_Name ("test1.ini"),
"check if file name is correctly retrieved from system ID");
Sys.Next;
declare
D : constant String := Sys.As_Absolute_Dir;
begin
A.Assert (D (D'First .. D'Last - 1), Dir.Full_Name (".."), -- strip sep
"check if dir is correctly retrieved from system ID");
end;
-- Check the rest of As_* functionality
Sys.Next;
A.Assert (Sys.As_Boolean,
"check if boolean is correctly retrieved");
Sys.Next;
A.Assert (Sys.As_Integer, 15,
"check if integer is correctly retrieved");
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/config/test6.ini 0000644 0001750 0001750 00000000014 13661715457 022405 0 ustar nicolas nicolas [
key=value
gnatcoll-core-21.0.0/testsuite/tests/config/test3.ini 0000644 0001750 0001750 00000000034 13661715457 022404 0 ustar nicolas nicolas key1 = value1_2
key7=value7
gnatcoll-core-21.0.0/testsuite/tests/config/test.yaml 0000644 0001750 0001750 00000000072 13661715457 022506 0 ustar nicolas nicolas description: Test for GNATCOLL.Config
data:
- "*.ini"
gnatcoll-core-21.0.0/testsuite/tests/config/test4.ini 0000644 0001750 0001750 00000000073 13661715457 022410 0 ustar nicolas nicolas key8 = $e
key9 = $:
key10 = $(
key11 = ${a
=value12
key12=
gnatcoll-core-21.0.0/testsuite/tests/storage_pools/ 0000755 0001750 0001750 00000000000 13661715457 022257 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/storage_pools/headers_with_auxdec/ 0000755 0001750 0001750 00000000000 13743647711 026254 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/storage_pools/headers_with_auxdec/test.adb 0000644 0001750 0001750 00000002200 13661715457 027677 0 ustar nicolas nicolas -- Very simple test of GNATCOLL.Storage_Pools.Headers checking that it is
-- useable together with DEC system extensions (S507-006).
pragma Extend_System (Aux_DEC);
with GNATCOLL.Storage_Pools.Headers; use GNATCOLL.Storage_Pools.Headers;
with Ada.Text_IO; use Ada.Text_IO;
with System.Address_Image;
with Test_Assert;
function Test return Integer is
package A renames Test_Assert;
type Header is record
Refcount : Natural := 0;
end record;
type Header_Access is access all Header;
package Pools is new Header_Pools (Header, Header_Access);
package String_Pools is new Pools.Typed (String);
Str : String_Pools.Element_Access;
Hdr : Header_Access;
begin
-- Allocate element from the typed storage pool then retrieve
-- and access its header
Str := new String'("foo");
Put_Line (System.Address_Image (Str.all'Address));
Hdr := String_Pools.Header_Of (Str);
Put_Line (System.Address_Image (Hdr.all'Address));
String_Pools.Header_Of (Str).all.Refcount := 1;
A.Assert (Hdr.all.Refcount = 1, "unexpected ref count from extra header");
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/storage_pools/headers_with_auxdec/test.yaml 0000644 0001750 0001750 00000000227 13743647711 030120 0 ustar nicolas nicolas description: Test GNATCOLL.Storage_Pools.Headers with Extend_System(Aux_DEC)
control:
- [XFAIL, "env.valgrind", "Known memory leak: see S912-005"]
gnatcoll-core-21.0.0/testsuite/tests/strings/ 0000755 0001750 0001750 00000000000 13661715457 021070 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/strings/basics/ 0000755 0001750 0001750 00000000000 13661715457 022334 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/strings/basics/memory.ads 0000644 0001750 0001750 00000003337 13661715457 024343 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- Copyright (C) 2015-2016, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
package Memory is
Allocs : Integer := 0;
-- Incremented every time we do a malloc
Reallocs : Integer := 0;
-- Incremented every time we do a realloc
end Memory;
gnatcoll-core-21.0.0/testsuite/tests/strings/basics/test.adb 0000644 0001750 0001750 00000141753 13661715457 023776 0 ustar nicolas nicolas with Ada.Command_Line; use Ada.Command_Line;
with GNATCOLL.Asserts;
with GNATCOLL.Strings;
with GNATCOLL.Strings_Impl;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Wide_Characters.Handling; use Ada.Wide_Characters.Handling;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Source_Info;
with GNAT.Strings; use GNAT.Strings;
with Memory;
pragma Warnings (Off);
with System.Memory;
pragma Warnings (On);
with Test_Assert;
function Test return Integer is
package A renames Test_Assert;
generic
with package Strings is new GNATCOLL.Strings_Impl.Strings (<>);
with function Image (S : Strings.Char_String) return String is <>;
First_Displayable : Strings.Char_Type :=
Strings.Char_Type'Val (Character'Pos ('A'));
procedure Do_Test (Title : String);
-- Tests for various instances of xstring
type On_Error is new GNATCOLL.Asserts.Error_Reporter with null record;
overriding procedure On_Assertion_Failed
(Self : On_Error;
Msg : String;
Details : String;
Location : String;
Entity : String);
Report : On_Error;
package Asserts is new GNATCOLL.Asserts.Asserts (Report);
package Equals_Boolean is new Asserts.Equals (Boolean, Boolean'Image);
package Equals_Integer is new Asserts.Equals (Integer, Integer'Image);
use Equals_Boolean, Equals_Integer;
function Image (S : String) return String is ("--" & S & "--");
function Image (S : Wide_String) return String;
-- For convenience of instantiation of Asserts, below.
procedure Reset_Mem;
-- Reset memory allocation counters
---------------
-- Reset_Mem --
---------------
procedure Reset_Mem is
begin
Memory.Allocs := 0;
Memory.Reallocs := 0;
end Reset_Mem;
-----------
-- Image --
-----------
function Image (S : Wide_String) return String is
Result : Unbounded_String;
begin
Append (Result, "--");
for C of S loop
if Wide_Character'Pos (C) <= 127 then
Append (Result, Character'Val (Wide_Character'Pos (C)));
else
Append (Result, '['
& Integer'Image (Wide_Character'Pos (C))
& ']');
end if;
end loop;
Append (Result, "--");
return To_String (Result);
end Image;
-------------------------
-- On_Assertion_Failed --
-------------------------
overriding procedure On_Assertion_Failed
(Self : On_Error;
Msg : String;
Details : String;
Location : String;
Entity : String)
is
pragma Unreferenced (Self);
begin
Put_Line
((if Msg = "" then "" else Msg & " ")
& "(at " & Location & ", in " & Entity & ")"
& ASCII.LF & " " & Details);
end On_Assertion_Failed;
-------------
-- Do_Test --
-------------
procedure Do_Test (Title : String) is
use Strings;
function Image (S : XString) return String is
(Image (S.To_String));
package Equals1 is new Asserts.Equals
(T => Strings.Char_Type,
Image => Strings.Char_Type'Image);
package Equals2 is new Asserts.Equals
(T => Strings.Char_String,
Image => Image);
use Equals1, Equals2;
generic
type Left_Type (<>) is private;
type Right_Type (<>) is private;
Op : String;
with function Compare
(Left : Left_Type; Right : Right_Type) return Boolean;
with function Image (L : Left_Type) return String is <>;
with function Image (L : Right_Type) return String is <>;
procedure Assert_Generic
(Left : Left_Type; Right : Right_Type;
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity);
procedure Assert_Generic
(Left : Left_Type; Right : Right_Type;
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity)
is
begin
if not Compare (Left, Right) then
Asserts.Assert_Failed
(Image (Left) & ' ' & Op & ' ' & Image (Right),
Location => Location, Entity => Entity);
end if;
end Assert_Generic;
procedure Assert is new Assert_Generic (XString, Char_String, "=", "=");
procedure Assert is
new Assert_Generic (Char_String, XString, "=", "=");
procedure Assert is new Assert_Generic (XString, XString, "=", "=");
procedure Assert_Less is
new Assert_Generic (XString, Char_String, "<", "<");
procedure Assert_Less is
new Assert_Generic (Char_String, XString, "<", "<");
procedure Assert_Less is
new Assert_Generic (XString, XString, "<", "<");
procedure Assert_Less_Equal is
new Assert_Generic (XString, Char_String, "<=", "<=");
procedure Assert_Less_Equal is
new Assert_Generic (Char_String, XString, "<=", "<=");
procedure Assert_Less_Equal is
new Assert_Generic (XString, XString, "<=", "<=");
procedure Assert_Greater is
new Assert_Generic (XString, Char_String, ">", ">");
procedure Assert_Greater is
new Assert_Generic (Char_String, XString, ">", ">");
procedure Assert_Greater is
new Assert_Generic (XString, XString, ">", ">");
procedure Assert_Greater_Equal is
new Assert_Generic (XString, Char_String, ">=", ">=");
procedure Assert_Greater_Equal is
new Assert_Generic (Char_String, XString, ">=", ">=");
procedure Assert_Greater_Equal is
new Assert_Generic (XString, XString, ">=", ">=");
Space : constant Char_Type := Char_Type'Val (Character'Pos (' '));
Spaces : constant Char_String := Space & Space;
Newline : constant Char_Type := Char_Type'Val (Character'Pos (ASCII.LF));
Equal : constant Char_Type := Char_Type'Val (Character'Pos ('='));
Empty : Char_String (1 .. 0);
Short : Char_String (3 .. 7);
Long : Char_String (3 .. Integer (Strings.SSize'Last) + 10);
Null_String : Char_String (1 .. 0);
procedure Test_Append;
procedure Test_Compare;
procedure Test_Indexing (Base : Char_String);
procedure Test_Trim;
procedure Test_Substrings;
procedure Test_Starts;
procedure Test_Head_Tail;
procedure Test_Iterate;
procedure Test_Modify (Base : Char_String);
procedure Test_Shrink;
procedure Test_Swap;
procedure Test_Justify (Base : Char_String);
procedure Test_Split (Base : Char_String);
procedure Test_Search (Base : Char_String);
procedure Test_Casing;
procedure Test_Access;
-----------------
-- Test_Append --
-----------------
procedure Test_Append is
S, S2 : XString;
begin
S.Set (Short);
A.Assert (S = Short, Title);
S.Set (Long);
A.Assert (S = Long, Title);
S2 := S;
Append (S, Short);
A.Assert (S2 = Long, Title);
A.Assert (S = Long & Short, Title);
S.Set (Short);
A.Assert (S = Short, Title);
A.Assert (S2 = Long, Title);
-- Appending to a slice
S.Set (Long);
S2 := S;
S.Slice (2, 3);
S.Append (Short);
A.Assert (S2 = Long, Title);
A.Assert
(S =
Long (Long'First + 1 .. Long'First + 2)
& Short,
Title);
end Test_Append;
------------------
-- Test_Compare --
------------------
procedure Test_Compare is
S, S2 : XString;
begin
-- Test equality between null strings
S := Null_XString;
if S /= Null_XString then
raise Program_Error;
end if;
A.Assert (S.Is_Empty = True, Title);
-- Test equality for short string and null string
S := Null_XString;
S.Set (Empty);
A.Assert (S = Empty, Title);
if S /= Null_XString then
raise Program_Error;
end if;
Assert (Compare (S, Empty), 0);
-- Test equality for big string and null string
S := Null_XString;
S.Set (Long); -- force malloc
S.Set (Empty); -- reset to empty string
A.Assert (S = Empty, Title);
if S /= Null_XString then
raise Program_Error;
end if;
A.Assert (S.Is_Empty = True, Title);
A.Assert (Compare (S, Empty) = 0, Title);
-- Test equality for short strings
S := Null_XString;
S2 := Null_XString;
S.Set (Short);
S2.Set (Short);
if S /= S2 then
raise Program_Error;
end if;
-- Test equality for long strings
S := Null_XString;
S2 := Null_XString;
S.Set (Long);
S2.Set (Long);
if S /= S2 then
raise Program_Error;
end if;
-- Test equality for short and long strings
S := Null_XString;
S2 := Null_XString;
S.Set (Long); -- force malloc
S.Set (Short);
S2.Set (Short);
if S /= S2 then
raise Program_Error;
end if;
-- Test equality with Char_String
declare
XS : XString;
S : Char_String := Short;
begin
XS.Set (Short);
A.Assert (To_String(XS) = S, Title);
A.Assert (To_XString(S) = XS, Title);
A.Assert (Compare (XS, S) = 0, Title);
end;
-- Test equality with substrings
declare
S, S2, S3 : XString;
begin
S.Set (Short);
S2.Set (Long);
A.Assert (S = Short, Title);
A.Assert (Short = S, Title);
A.Assert (S2 = Long, Title);
A.Assert (Long = S2, Title);
A.Assert (S.Slice (2, 3) = S.Slice (2, 3), Title);
A.Assert (Compare (S.Slice (2, 3), S.Slice (2, 3)) = 0, Title);
A.Assert (S.Slice (2, 3) = S2.Slice (2, 3), Title);
A.Assert (Compare (S.Slice (2, 3), S2.Slice (2, 3)) = 0, Title);
A.Assert (S2.Slice (2, 3) = S.Slice (2, 3), Title);
A.Assert (Compare (S2.Slice (2, 3), S.Slice (2, 3)) = 0, Title);
A.Assert (S2.Slice (2, 3) = S2.Slice (2, 3), Title);
A.Assert (Compare (S2.Slice (2, 3), S2.Slice (2, 3)) = 0, Title);
-- Test inequality with substring
A.Assert (Compare(S2,S) = 1, Title);
A.Assert (Compare(S,S2) = -1, Title);
-- Check that we have the same behavior as with standard strings
A.Assert (S.Slice (3, 2) = Null_XString, Title);
A.Assert (S.Slice (Natural'Last, 1) = Null_XString, Title);
A.Assert (S.Slice (1, 0) = Null_XString, Title);
S3 := S2;
S3.Slice (3, 2);
A.Assert (S3 = Null_XString, Title);
S3 := S2;
S3.Slice (Natural'Last, 1);
A.Assert (S3 = Null_XString, Title);
S3 := S2;
S3.Slice (3, 0);
A.Assert (S3 = Null_XString, Title);
end;
declare
S, S2, S3 : XString;
begin
S.Set (Short);
S2.Set (Long);
Assert_Less (S, S2);
Assert_Greater (S2, S);
Assert_Less (S, Short (Short'First + 1 .. Short'Last));
Assert_Less_Equal (S, Short (Short'First + 1 .. Short'Last));
Assert_Greater_Equal (Short (Short'First + 1 .. Short'Last), S);
Assert_Greater (Short (Short'First + 1 .. Short'Last), S);
Assert_Less (Short, S.Slice (2, 3));
Assert_Less_Equal (Short, S.Slice (2, 3));
Assert_Greater_Equal (S.Slice (2, 3), Short);
Assert_Greater (S.Slice (2, 3), Short);
A.Assert (Compare (S, Short (Short'First + 1 .. Short'Last)) = -1,
Title);
A.Assert (Compare (Short (Short'First + 1 .. Short'Last), S) = 1,
Title);
Assert_Less (S2, Long (Long'First + 1 .. Long'Last));
Assert_Less (Long, S2.Slice (2, 3));
A.Assert (Compare (S2, Long (Long'First + 1 .. Long'Last)) = -1,
Title);
A.Assert (Compare (Long (Long'First + 1 .. Long'Last), S2) = 1,
Title);
A.Assert (Compare (S, S) = 0, Title);
A.Assert (Compare (S2, S2) = 0, Title);
S3.Set(Short(Short'First) &
Char_Type'Val(Char_Type'Pos(Short(Short'First + 1)) + 1) &
Short(Short'First + 2..Short'Last));
A.Assert (Compare (S3, S) = 1, Title);
end;
end Test_Compare;
-------------------
-- Test_Indexing --
-------------------
procedure Test_Indexing (Base : Char_String) is
Is_Long : constant Boolean :=
Base'Length > Natural (Strings.SSize'Last);
S, S2 : XString;
Idx : Positive;
begin
S.Set (Base);
Reset_Mem;
-- Test the constant indexing aspect
-- We check memory allocations to make sure we are using
-- a constant indexing aspect
if S (1) /= First_Displayable then
raise Program_Error;
end if;
if S (2) /= Char_Type'Succ (First_Displayable) then
raise Program_Error;
end if;
A.Assert (Memory.Allocs = 0, Title);
A.Assert (Memory.Reallocs = 0, Title);
begin
if S (10000) /= First_Displayable then
null;
end if;
if S (Base'Length + 1) /= First_Displayable then
null;
end if;
raise Program_Error; -- should have receive exeption
exception
when Ada.Strings.Index_Error =>
null;
end;
-- Testing loops
-- We check memory allocations to make sure we are using
-- a constant indexing aspect
Reset_Mem;
Idx := Base'First;
for C of S loop
Assert (C, Base (Idx));
Idx := Idx + 1;
end loop;
Assert (Idx, Base'Last + 1);
S2 := S; -- Test that the string is still shareable
A.Assert (S = Base, Title);
A.Assert (S2 = Base, Title);
A.Assert (Memory.Allocs = (if not Strings.Copy_On_Write and then
Is_Long then 1 else 0), Title);
A.Assert (Memory.Reallocs = 0, Title);
-- Same test for loops on indexes
Reset_Mem;
Idx := Base'First;
for Idx2 in S.Iterate loop
A.Assert (Idx2 = Idx - Base'First + 1, Title);
A.Assert (S (Idx2) = Base (Idx), Title);
Idx := Idx + 1;
end loop;
Assert (Idx, Base'Last + 1);
S2 := S;
A.Assert (S = Base, Title);
A.Assert (S2 = Base, Title);
A.Assert (Memory.Allocs = (if not Strings.Copy_On_Write and then
Is_Long then 1 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
-- Test the Variable indexing aspect
S.Set (Base);
S (2) := First_Displayable;
A.Assert (S = Base (Base'First) & First_Displayable
& Base (Base'First + 2 .. Base'Last), Title);
Reset_Mem;
S.Set (Base);
S2 := S;
S (2) := First_Displayable; -- makes a copy
A.Assert (S2 = Base, Title);
A.Assert (S = Base (Base'First) & First_Displayable
& Base (Base'First + 2 .. Base'Last), Title);
A.Assert (Memory.Allocs = (if Is_Long then 1 else 0), Title);
A.Assert (Memory.Reallocs = 0, Title);
Reset_Mem;
S.Set (Base);
declare
R : Character_Reference := S.Reference (2);
begin
S2 := S;
R := First_Displayable;
A.Assert (S2 = Base, Title);
A.Assert (S = Base (Base'First) & First_Displayable
& Base (Base'First + 2 .. Base'Last),
Title);
end;
A.Assert (Memory.Allocs = (if Is_Long then 1 else 0), Title);
A.Assert (Memory.Reallocs = 0, Title);
end Test_Indexing;
---------------
-- Test_Trim --
---------------
procedure Test_Trim is
pragma Compile_Time_Error
(Short'Length + 2 * Spaces'Length > Integer (SSize'Last),
"Cannot test short string with spaces");
-- So that we can test Trim with small strings.
S, S2 : XString;
begin
-- Short strings
S.Set (Spaces & Short & Spaces);
A.Assert (S.Trim (Chars => Space) = Short, Title);
A.Assert (S.Trim (Ada.Strings.Right) = Spaces & Short, Title);
A.Assert (S.Trim (Ada.Strings.Left) = Short & Spaces, Title);
S.Trim (Chars => Space);
A.Assert (S = Short, Title);
S.Set (Spaces & Short & Spaces);
S.Trim (Side => Ada.Strings.Right, Chars => Space);
A.Assert (S = Spaces & Short, Title);
S.Set (Spaces & Short & Spaces);
S.Trim (Side => Ada.Strings.Left, Chars => Space);
A.Assert (S = Short & Spaces, Title);
-- Long strings
S.Set (Spaces & Long & Spaces);
A.Assert (S.Trim = Long, Title);
A.Assert (S.Trim (Ada.Strings.Right) = Spaces & Long, Title);
A.Assert (S.Trim (Ada.Strings.Left) = Long & Spaces, Title);
S2 := S;
S.Trim (Chars => Space);
A.Assert (S = Long, Title);
S := S2;
S.Trim (Side => Ada.Strings.Right, Chars => Space);
A.Assert (S = Spaces & Long, Title);
S := S2;
S.Trim (Side => Ada.Strings.Left, Chars => Space);
A.Assert (S = Long & Spaces, Title);
-- Long strings with First /= 1
S.Set (Spaces & Spaces & Long & Spaces & Spaces);
S.Slice (3, Spaces'Length * 4 + Long'Length - 2);
A.Assert (S.Trim = Long, Title);
A.Assert (S.Trim (Ada.Strings.Right) = Spaces & Long, Title);
A.Assert (S.Trim (Ada.Strings.Left) = Long & Spaces, Title);
S2 := S;
S.Trim;
A.Assert (S = Long, Title);
S := S2;
S.Trim (Ada.Strings.Right);
A.Assert (S = Spaces & Long, Title);
S := S2;
S.Trim (Ada.Strings.Left);
A.Assert (S = Long & Spaces, Title);
end Test_Trim;
---------------------
-- Test_Substrings --
---------------------
procedure Test_Substrings is
S, S2, S3 : XString;
begin
-- Short strings
S.Set (Spaces & Short & Spaces);
S2 := S; -- shared buffer
S.Trim; -- get a substring
S2.Append (Short); -- no longer shared
S3 := S; -- shared buffer
S3.Append (Short); -- no longer shared
A.Assert (S = Short, Title);
A.Assert (S2 = Spaces & Short & Spaces & Short, Title);
A.Assert (S3 = Short & Short, Title);
-- Check that first character is still index 1 even with
-- small strings.
A.Assert (S (1) = First_Displayable, Title);
end Test_Substrings;
-----------------
-- Test_Starts --
-----------------
procedure Test_Starts is
S : XString;
begin
S.Set (Short);
A.Assert (S.Starts_With (Short) = True, Title);
A.Assert (S.Starts_With (Short (3 .. 4)) = True, Title);
A.Assert (S.Starts_With (Null_XString) = True, Title);
A.Assert (S.Starts_With (Null_String) = True, Title);
A.Assert (S.Starts_With (Short & First_Displayable) = False, Title);
A.Assert (S.Ends_With (Short) = True, Title);
A.Assert (S.Ends_With (Short (Short'Last - 1 .. Short'Last)) = True,
Title);
A.Assert (S.Ends_With (Null_XString) = True, Title);
A.Assert (S.Ends_With (Null_String) = True, Title);
A.Assert (S.Ends_With (Short & First_Displayable) = False, Title);
S.Set (Long);
A.Assert (S.Starts_With (Long) = True, Title);
A.Assert (S.Starts_With (Long (3 .. 4)) = True, Title);
A.Assert (S.Starts_With (Null_XString) = True, Title);
A.Assert (S.Starts_With (Null_String) = True, Title);
A.Assert (S.Starts_With (Long & First_Displayable) = False, Title);
A.Assert (S.Ends_With (Long) = True, Title);
A.Assert (S.Ends_With (Long (Long'Last - 1 .. Long'Last)) = True,
Title);
A.Assert (S.Ends_With (Null_XString) = True, Title);
A.Assert (S.Ends_With (Null_String) = True, Title);
A.Assert (S.Ends_With (Long & First_Displayable) = False, Title);
end Test_Starts;
--------------------
-- Test_Head_Tail --
--------------------
procedure Test_Head_Tail is
S, S2 : XString;
begin
S.Set (Short);
A.Assert (S.Head (1) = Short (Short'First .. Short'First), Title);
A.Assert (S.Head (2) = Short (Short'First .. Short'First + 1), Title);
A.Assert (S.Head (1000) = Short, Title);
A.Assert (S.Tail (1) = Short (Short'Last .. Short'Last), Title);
A.Assert (S.Tail (2) = Short (Short'Last - 1 .. Short'Last), Title);
A.Assert (S.Tail (1000) = Short, Title);
S.Set (Long);
A.Assert (S.Head (1) = Long (Long'First .. Long'First), Title);
A.Assert (S.Head (2) = Long (Long'First .. Long'First + 1), Title);
A.Assert (S.Head (1000) = Long, Title);
A.Assert (S.Tail (1) = Long (Long'Last .. Long'Last), Title);
A.Assert (S.Tail (2) = Long (Long'Last - 1 .. Long'Last), Title);
A.Assert (S.Tail (1000) = Long, Title);
S.Set (Long);
S.Slice (3, 10);
A.Assert (S.Head (1) = Long (Long'First + 2 .. Long'First + 2), Title);
A.Assert (S.Head (2) = Long (Long'First + 2 .. Long'First + 3), Title);
A.Assert (S.Head (1000) = Long (Long'First + 2 .. Long'First + 9),
Title);
A.Assert (S.Tail (1) = Long (Long'First + 9 .. Long'First + 9), Title);
A.Assert (S.Tail (2) = Long (Long'First + 8 .. Long'First + 9), Title);
A.Assert (S.Tail (1000) =Long (Long'First + 2 .. Long'First + 9), Title);
-- A slice into itself
S.Set (Long);
S.Slice (3, 10, Into => S);
A.Assert (S = Long (Long'First + 2 .. Long'First + 9), Title);
-- A slice into an already allocated string should not leak
-- memory.
S.Set (Long);
S2.Set (Long);
S.Slice (3, 10, Into => S2);
A.Assert (S = Long, Title);
A.Assert (S2 = Long (Long'First + 2 .. Long'First + 9), Title);
end Test_Head_Tail;
------------------
-- Test_Iterate --
------------------
procedure Test_Iterate is
S : XString;
Expected : Natural;
E : Char_Type;
begin
-- Iterate on indexes, short string
S.Set (Short);
Expected := 1;
for Index of S.Iterate loop
A.Assert (Index = Expected, Title);
Expected := Expected + 1;
end loop;
A.Assert (Expected = Short'Length + 1, Title);
Expected := 1;
for Index of S.Slice (2, 3).Iterate loop
A.Assert (Index = Expected, Title);
Expected := Expected + 1;
end loop;
A.Assert (Expected = 3, Title);
-- Iterate on characters, short string
E := First_Displayable;
for C of S loop
A.Assert (C = E, Title);
E := Char_Type'Succ (E);
end loop;
A.Assert (Char_Type'Pos (E) =
Char_Type'Pos (First_Displayable) + Short'Length,
Title);
E := Char_Type'Succ (First_Displayable);
for C of S.Slice (2, 3) loop
A.Assert (C = E, Title);
E := Char_Type'Succ (E);
end loop;
A.Assert (Char_Type'Pos (E) =
Char_Type'Pos (First_Displayable) + 3, Title);
-- Iterate on indexes, long string
S.Set (Long);
Expected := 1;
for Index of S.Iterate loop
A.Assert (Index = Expected, Title);
Expected := Expected + 1;
end loop;
A.Assert (Expected = Long'Length + 1, Title);
Expected := 1;
for Index of S.Slice (2, 10).Iterate loop
A.Assert (Index = Expected, Title);
Expected := Expected + 1;
end loop;
A.Assert (Expected = 10, Title);
-- Iterate on characters, long string
E := First_Displayable;
for C of S loop
A.Assert (C = E, Title);
E := Char_Type'Succ (E);
end loop;
A.Assert (Char_Type'Pos (E) =
Char_Type'Pos (First_Displayable) + Long'Length,
Title);
E := Char_Type'Succ (First_Displayable);
for C of S.Slice (2, 10) loop
A.Assert (C = E, Title);
E := Char_Type'Succ (E);
end loop;
A.Assert (Char_Type'Pos (E) =
Char_Type'Pos (First_Displayable) + 10, Title);
end Test_Iterate;
-----------------
-- Test_Modify --
-----------------
procedure Test_Modify(Base : Char_String) is
S, S2 : XString;
begin
S.Set (Base);
S2 := S;
S.Replace (2, First_Displayable);
A.Assert
(S =
Base (Base'First)
& First_Displayable
& Base (Base'First + 2 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Replace with small string
S.Set (Base);
S2 := S;
S.Replace (2, 3, (3 => First_Displayable));
A.Assert
(S =
Base (Base'First)
& First_Displayable
& Base (Base'First + 3 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Replace with longer string
S.Set (Base);
S2 := S;
S.Replace (2, 3, (3 .. 20 => First_Displayable));
A.Assert
(S =
Base (Base'First)
& (3 .. 20 => First_Displayable)
& Base (Base'First + 3 .. Base'Last),
Title);
A.Assert (S2 = Base,
Title);
-- Replace an empty string (same as insert)
S.Set (Base);
S2 := S;
S.Replace (2, 1, (3 .. 20 => First_Displayable));
A.Assert
(S =
Base (Base'First)
& (3 .. 20 => First_Displayable)
& Base (Base'First + 1 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Replace with self
S.Set (Base);
S.Replace_Slice (1, 1, S);
A.Assert
(S =
Base
& Base (Base'First + 1 .. Base'Last),
Title);
S.Set (Base);
S2 := S;
S.Insert (3, First_Displayable & First_Displayable);
A.Assert
(S =
Base (Base'First .. Base'First + 1)
& First_Displayable & First_Displayable
& Base (Base'First + 2 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Overwrite with shorter string
S.Set (Base);
S2 := S;
S.Overwrite (3, Base (Base'First .. Base'First + 1));
A.Assert
(S =
Base (Base'First .. Base'First + 1)
& Base (Base'First .. Base'First + 1)
& Base (Base'First + 4 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Overwrite with longer string
S.Set (Base);
S2 := S;
S.Overwrite (3, Base);
A.Assert
(S =
Base (Base'First .. Base'First + 1)
& Base,
Title);
A.Assert (S2 = Base, Title);
-- Deleting
S.Set (Base);
S2 := S;
S.Delete (3, 4);
A.Assert
(S =
Base (Base'First .. Base'First + 1)
& Base (Base'First + 4 .. Base'Last),
Title);
A.Assert (S2 = Base, Title);
-- Deleting past the end
S.Set (Base);
S2 := S;
S.Delete (3, 10_000);
A.Assert
(S =
Base (Base'First .. Base'First + 1),
Title);
A.Assert (S2 = Base, Title);
-- Clearing the string
S.Set (Base);
S2 := S;
S.Clear;
A.Assert (S2 = Base, Title);
A.Assert (S = Null_String, Title);
end Test_Modify;
-----------------
-- Test_Shrink --
-----------------
procedure Test_Shrink is
S : XString;
begin
S.Set (Short);
S.Shrink;
A.Assert (S = Short, Title);
S := 50 * Long;
S.Set (Long);
S.Shrink;
A.Assert (S = Long, Title);
S.Set (Short);
S.Shrink;
A.Assert (S = Short, Title);
end Test_Shrink;
---------------
-- Test_Swap --
---------------
procedure Test_Swap is
S, S2 : XString;
begin
-- Swapping two short strings
S.Set (Short);
S2.Set (Spaces);
S.Swap (S2);
A.Assert (S = Spaces, Title);
A.Assert (S2 = Short, Title);
S.Swap (S2);
A.Assert (S = Short, Title);
A.Assert (S2 = Spaces, Title);
-- Swapping a short and a long string
S.Set (Short);
S2.Set (Long);
S.Swap (S2);
A.Assert (S = Long, Title);
A.Assert (S2 = Short, Title);
S.Swap (S2);
A.Assert (S = Short, Title);
A.Assert (S2 = Long, Title);
-- Swapping self
S.Set (Short);
S.Swap (S);
A.Assert (S = Short, Title);
S.Set (Long);
S.Swap (S);
A.Assert (S = Long, Title);
end Test_Swap;
------------------
-- Test_Justify --
------------------
procedure Test_Justify (Base : Char_String) is
S, S2 : XString;
begin
-- procedure Center
S.Set (Base);
S.Center (Width => Base'Length + 4);
A.Assert (S = Space & Space & Base & Space & Space, Title);
S.Clear;
S.Set (Base);
S.Center (Width => Base'Length + 3);
A.Assert (S = Space & Space & Base & Space, Title);
S.Clear;
S.Set (Base);
S.Center (Width => Base'Length - 1);
A.Assert (S = Base, Title);
S.Clear;
S.Set (Base);
S.Center (Base'Length + 2, First_Displayable);
A.Assert (S = First_Displayable & Base & First_Displayable, Title);
-- function Center
S.Clear;
S.Set (Base);
A.Assert (S.Center (Base'Length + 4) =
Space & Space & Base & Space & Space,
Title);
A.Assert (S.Center (Base'Length + 3) =
Space & Space & Base & Space,
Title);
A.Assert (S.Center (Base'Length - 1) = Base, Title);
-- procedure Left justify
S.Clear;
S.Set (Base);
S.Left_Justify (Width => Base'Length + 2);
A.Assert (S = Base & Space & Space, Title);
S.Clear;
S.Set (Base);
S.Left_Justify (Width => Base'Length - 1);
A.Assert (S = Base, Title);
S.Clear;
S.Set (Base);
S.Left_Justify (Base'Length + 2, First_Displayable);
A.Assert (S = Base & First_Displayable & First_Displayable, Title);
-- function Left justify
S.Clear;
S.Set (Base);
A.Assert (S.Left_Justify (Base'Length + 2) = Base & Space & Space,
Title);
A.Assert (S.Left_Justify (Base'Length - 1) = Base,
Title);
A.Assert (S.Left_Justify (Base'Length + 2, First_Displayable) =
Base & First_Displayable & First_Displayable,
Title);
-- procedure Right justify
S.Clear;
S.Set (Base);
S.Right_Justify (Width => Base'Length + 2);
A.Assert (S = Space & Space & Base, Title);
S.Clear;
S.Set (Base);
S.Right_Justify (Width => Base'Length - 1);
A.Assert (S = Base, Title);
S.Clear;
S.Set (Base);
S.Right_Justify (Base'Length + 2, First_Displayable);
A.Assert (S = First_Displayable & First_Displayable & Base,
Title);
-- function Right justify
S.Set (Base);
A.Assert (S.Right_Justify (Base'Length + 2) = Space & Space & Base,
Title);
A.Assert (S.Right_Justify (Base'Length - 1) = Base,
Title);
A.Assert (S.Right_Justify (Base'Length + 2, First_Displayable) =
First_Displayable & First_Displayable & Base,
Title);
end Test_Justify;
----------------
-- Test_Split --
----------------
procedure Test_Split (Base : Char_String) is
Is_Long : constant Boolean :=
Base'Length > Natural (Strings.SSize'Last);
S, S2 : XString;
begin
S.Set (Space
& Space
& Base & Space
& Base & Space
& Base & Space
& Space);
Reset_Mem;
declare
R : constant XString_Array := S.Split (Space);
begin
-- 3 copies per non-null substring when not copy-on-write
-- 1 copy when creating the slide
-- 2 copies when returning the array, since have a temporary
-- created by the compiler
A.Assert (Memory.Allocs =
(if Is_Long and not Copy_On_Write then 9 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
A.Assert (R'Length = 7, Title);
A.Assert (R (R'First + 0) = Null_XString, Title);
A.Assert (R (R'First + 1) = Null_String, Title);
A.Assert (R (R'First + 2) = Base, Title);
A.Assert (R (R'First + 3) = Base, Title);
A.Assert (R (R'First + 4) = Base, Title);
A.Assert (R (R'First + 5) = Null_String, Title);
A.Assert (R (R'First + 6) = Null_String, Title);
S2.Set_As_Join (Space, R);
A.Assert (S2 = S, Title);
A.Assert (Join (Space, R) = S, Title);
A.Assert (Join ((1 => Space), R) = S, Title);
end;
Reset_Mem;
declare
R : XString_Array (1 .. 20);
Last : Natural;
begin
S.Split (Space, Into => R, Last => Last);
-- One copy per non-null substring when not copy-on-write
A.Assert (Memory.Allocs =
(if Is_Long and not Copy_On_Write then 3 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
A.Assert (Last = 7, Title);
end;
Reset_Mem;
declare
R : constant XString_Array := S.Right_Split (Space);
begin
-- Three copies per non-null substring when not copy-on-write
A.Assert (Memory.Allocs =
(if Is_Long and not Copy_On_Write then 9 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
A.Assert (R'Length = 7, Title);
A.Assert (R (R'First + 6) = Null_XString, Title);
A.Assert (R (R'First + 5) = Null_String, Title);
A.Assert (R (R'First + 4) = Base, Title);
A.Assert (R (R'First + 3) = Base, Title);
A.Assert (R (R'First + 2) = Base, Title);
A.Assert (R (R'First + 1) = Null_String, Title);
A.Assert (R (R'First + 0) = Null_String, Title);
end;
Reset_Mem;
declare
R : XString_Array (1 .. 20);
Last : Natural;
begin
S.Right_Split (Space, Into => R, Last => Last);
A.Assert (Memory.Allocs =
(if Is_Long and not Copy_On_Write then 3 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
A.Assert (Last = 7, Title);
end;
declare
R : constant XString_Array := S.Split (Space, Max_Split => 1);
R2 : constant XString_Array :=
S.Right_Split (Space, Max_Split => 1);
begin
A.Assert (R'Length = 1, Title);
A.Assert (R (R'First + 0) = S, Title);
A.Assert (R2'Length = 1, Title);
A.Assert (R2 (R2'First + 0) = S, Title);
S2.Set_As_Join (Space, R);
A.Assert (S2 = S, Title);
A.Assert (Join (Space, R) = S, Title);
A.Assert (Join ((1 => Space), R) = S, Title);
end;
declare
R : constant XString_Array := S.Split (Space, Max_Split => 2);
R2 : constant XString_Array :=
S.Right_Split (Space, Max_Split => 2);
begin
A.Assert (R'Length = 2, Title);
A.Assert (R (R'First + 0) = Null_XString, Title);
A.Assert (R (R'First + 1) =
Space & Base & Space & Base & Space & Base &
Space & Space,
Title);
A.Assert (R2'Length = 2, Title);
A.Assert (R2 (R2'First + 0) = Null_XString, Title);
A.Assert (R2 (R2'First + 1) =
Space & Space & Base & Space & Base & Space &
Base & Space,
Title);
S2.Set_As_Join (Space, R);
A.Assert (S2 = S, Title);
A.Assert (Join (Space, R) = S, Title);
A.Assert (Join ((1 => Space), R) = S, Title);
end;
declare
R : constant XString_Array := S.Split (Space, Omit_Empty => True);
R2 : constant XString_Array :=
S.Right_Split (Space, Omit_Empty => True);
begin
A.Assert (R'Length = 3, Title);
A.Assert (R (R'First + 0) = Base, Title);
A.Assert (R (R'First + 1) = Base, Title);
A.Assert (R (R'First + 2) = Base, Title);
A.Assert (R2'Length = 3, Title);
A.Assert (R2 (R2'First + 2) = Base, Title);
A.Assert (R2 (R2'First + 1) = Base, Title);
A.Assert (R2 (R2'First + 0) = Base, Title);
end;
declare
R : constant XString_Array :=
Null_XString.Split (Space, Omit_Empty => True);
R2 : constant XString_Array :=
Null_XString.Right_Split (Space, Omit_Empty => True);
begin
A.Assert (R'Length = 0, Title);
A.Assert (R2'Length = 0, Title);
end;
-- Splitting on strings
declare
R : constant XString_Array := S.Split (Space & Space);
begin
A.Assert (R'Length = 3, Title);
A.Assert (R (R'First + 0) = Null_XString, Title);
A.Assert (R (R'First + 1) = Base & Space & Base & Space & Base,
Title);
A.Assert (R (R'First + 2) = Null_XString, Title);
end;
declare
R : constant XString_Array :=
S.Split (Space & Space, Omit_Empty => True);
begin
A.Assert (R'Length = 1, Title);
A.Assert (R (R'First + 0) =
Base & Space & Base & Space & Base,
Title);
end;
A.Assert (Null_XString.Split (Space & Space)'Length = 0, Title);
A.Assert (Null_XString.Split (Null_String)'Length = 0, Title);
A.Assert (S.Split (Null_String)'Length = 0, Title);
declare
R : constant XString_Array := S.Right_Split (Space & Space);
begin
A.Assert (R'Length = 3, Title);
A.Assert (R (R'First + 0) = Null_XString, Title);
A.Assert (R (R'First + 1) = Base & Space & Base & Space & Base,
Title);
A.Assert (R (R'First + 2) = Null_XString, Title);
end;
declare
R : constant XString_Array :=
S.Right_Split (Space & Space, Omit_Empty => True);
begin
A.Assert (R'Length = 1, Title);
A.Assert (R (R'First + 0) = Base & Space & Base & Space & Base,
Title);
end;
A.Assert (Null_XString.Right_Split (Space & Space)'Length = 0, Title);
A.Assert (Null_XString.Right_Split (Null_String)'Length = 0, Title);
A.Assert (S.Right_Split (Null_String)'Length = 0, Title);
-- Joining
A.Assert (Join (Null_XString,
XString_Array'(1 .. 0 => Null_XString)) =
Null_XString,
Title);
A.Assert (Join (Space,
XString_Array'(1 .. 0 => Null_XString)) =
Null_XString,
Title);
A.Assert (Join (Space & Space,
XString_Array'(1 .. 0 => Null_XString)) =
Null_XString,
Title);
-- Parsing a file containing "key = value" lines
declare
L : XString_Array (1 .. 2);
Key, Value : XString;
Last : Natural;
begin
S.Set (Spaces & Newline
& Base & Equal & Base & Newline
& Base & Equal & Base & Newline
& Base & Equal & Base & Newline);
Reset_Mem;
for Line of S.Split (Newline) loop
Line.Split (Equal, Into => L, Last => Last);
if Last = 2 then
Key := L (1);
Key.Trim;
Value := L (2);
Value.Trim;
end if;
end loop;
A.Assert (Memory.Allocs =
(if Is_Long and not Copy_On_Write then 14 else 0),
Title);
A.Assert (Memory.Reallocs = 0, Title);
end;
end Test_Split;
-----------------
-- Test_Search --
-----------------
procedure Test_Search (Base : Char_String) is
S, S2 : XString;
begin
S.Set (Space
& Space
& Base & Space
& Base & Space
& Base & Space
& Space);
A.Assert (S.Count (Space) = 6, Title);
A.Assert (S.Count (Char_Type'Val (0)) = 0, Title);
A.Assert (S.Count (Space & Space) = 2, Title);
A.Assert
(S.Count (First_Displayable & Char_Type'Succ (First_Displayable)) =
3,
Title);
A.Assert (S.Count (Null_String) = Natural'Last, Title);
A.Assert (Null_XString.Count (Space) = 0, Title);
A.Assert (Null_XString.Count (Space & Space) = 0, Title);
A.Assert (Null_XString.Count (Null_String) = 0, Title);
A.Assert (S.Find (Space) = 1, Title);
A.Assert (S.Find (Space & Space) = 1, Title);
A.Assert (S.Slice (2, 3).Find (Space) = 1, Title);
A.Assert (S.Slice (3, Base'Length * 2).Find (Space) = Base'Length + 1,
Title);
A.Assert (S.Find (Space, Low => 2, High => 3) = 2, Title);
A.Assert (S.Find (Space, Low => 3) = Base'Length + 3, Title);
A.Assert (S.Find (Base, Low => 3, High => 4) = 0, Title);
A.Assert (S.Find (First_Displayable) = 3, Title);
A.Assert (S.Find (Base) = 3, Title);
A.Assert (S.Right_Find (Space) = S.Length, Title);
A.Assert (S.Right_Find (Space & Space) = S.Length - 1, Title);
A.Assert (S.Right_Find (Base) = S.Length - 1 - Base'Length, Title);
A.Assert (S.Find (First_Displayable & First_Displayable) = 0, Title);
A.Assert (S.Right_Find (First_Displayable & First_Displayable) = 0,
Title);
end Test_Search;
-----------------
-- Test_Casing --
-----------------
procedure Test_Casing is
S : XString;
S2 : XString;
begin
S.Set (Short);
A.Assert (S.Is_Upper = True, Title);
A.Assert (S.Is_Lower = False, Title);
S2 := To_Lower(S);
A.Assert (S2.Is_Upper = False, Title);
A.Assert (S2.Is_Lower = True, Title);
S.To_Lower;
A.Assert (S.Is_Upper = False, Title);
A.Assert (S.Is_Lower = True, Title);
S.Capitalize;
A.Assert ((Slice (S, 1, 1).Is_Upper and
Slice (S, 2, S.Length).Is_Lower) = True,
Title);
A.Assert ((Slice (S, 1, 1).Is_Lower or
Slice (S, 2, S.Length).Is_Upper) = False,
Title);
S2 := To_Upper(S);
A.Assert (S2.Is_Upper = True, Title);
A.Assert (S2.Is_Lower = False, Title);
S.To_Upper;
A.Assert (S.Is_Upper = True, Title);
A.Assert (S.Is_Lower = False, Title);
S.Set (Long);
A.Assert (S.Is_Upper = (Long'Length < 100), Title);
A.Assert (S.Is_Lower = False, Title);
S2 := To_Lower(S);
A.Assert (S2.Is_Upper = False, Title);
A.Assert (S2.Is_Lower = True, Title);
S.To_Lower;
A.Assert (S.Is_Upper = False, Title);
A.Assert (S.Is_Lower = True, Title);
S2 := To_Upper(S);
A.Assert (S2.Is_Upper = True, Title);
A.Assert (S2.Is_Lower = False, Title);
S.To_Upper;
A.Assert (S.Is_Upper = True, Title);
A.Assert (S.Is_Lower = False, Title);
S.Capitalize;
A.Assert ((Slice (S, 1, 1).Is_Upper and
Slice (S, 2, S.Length).Is_Lower) = True,
Title);
A.Assert ((Slice (S, 1, 1).Is_Lower or
Slice (S, 2, S.Length).Is_Upper) = False,
Title);
end Test_Casing;
-----------------
-- Test_Access --
-----------------
procedure Test_Access is
S : XString;
Is_Long : Boolean;
procedure Callback (Data : Char_String) is
begin
A.Assert (Data = (if Is_Long then Long else Short), Title);
S.Append (Space);
A.Assert (Data = (if Is_Long then Long else Short), Title);
A.Assert (S = (if Is_Long then Long else Short) & Space, Title);
S := Null_XString;
A.Assert (Data = (if Is_Long then Long else Short), Title);
end Callback;
begin
S.Set (Short);
Is_Long := False;
S.Access_String (Callback'Access);
S.Set (Long);
Is_Long := True;
S.Access_String (Callback'Access);
end Test_Access;
begin
declare
C : Char_Type := First_Displayable;
begin
for S in Short'Range loop
Short (S) := C;
C := Char_Type'Succ (C);
end loop;
C := First_Displayable;
for S in Long'Range loop
Long (S) := C;
C := Char_Type'Succ (C);
end loop;
end;
declare
-- coverage of function '*' (Count : Natural;
-- Right : Char_Type) return XString
-- and of function '*' (Count : Natural;
-- Right : XString) return XString
S1 : XString := 4 * First_Displayable;
S2 : XString := 4 * S1;
begin
A.Assert (S1.Length = 4);
A.Assert (S1 (1) = First_Displayable);
A.Assert (S1 (S1.Length) = First_Displayable);
A.Assert (S2.Length = 16);
A.Assert (S2 (1) = First_Displayable);
A.Assert (S2 (S2.Length) = First_Displayable);
end;
Test_Append;
Test_Compare;
Test_Indexing (Short);
Test_Indexing (Long);
Test_Trim;
Test_Substrings;
Test_Starts;
Test_Head_Tail;
Test_Iterate;
Test_Modify (Short);
Test_Modify (Long);
Test_Shrink;
Test_Swap;
Test_Justify (Short);
Test_Justify (Long);
Test_Search (Short);
Test_Search (Long);
Test_Split (Short);
Test_Split (Long);
Test_Casing;
Test_Access;
end Do_Test;
procedure Test_COW is new Do_Test (GNATCOLL.Strings);
package Basic_No_COW is new GNATCOLL.Strings_Impl.Strings
(GNATCOLL.Strings_Impl.Optimal_String_Size,
Character, String, Copy_On_Write => False);
procedure Test_No_COW is new Do_Test (Basic_No_COW);
type SSize_3 is mod 128;
package Strings3 is new GNATCOLL.Strings_Impl.Strings
(SSize_3, Character, String);
procedure Test3 is new Do_Test (Strings3);
type SSize_2 is mod 10;
package Wide is new GNATCOLL.Strings_Impl.Strings
(SSize_2,
Wide_Character, Wide_String, Copy_On_Write => True);
procedure Test_Wide is new Do_Test (Wide);
begin
Test_No_COW("basic strings, no COW");
Test_COW("basic strings, with COW");
Test3("strings with size" & SSize_3'Last'Img);
Test_Wide("wide strings");
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/strings/basics/test.yaml 0000644 0001750 0001750 00000000047 13661715457 024200 0 ustar nicolas nicolas description: Test for GNATCOLL.Strings
gnatcoll-core-21.0.0/testsuite/tests/strings/basics/test.gpr 0000644 0001750 0001750 00000000620 13661715457 024023 0 ustar nicolas nicolas with "gnatcoll";
project Test is
for Main use ("test.adb");
for Object_Dir use "obj";
for Source_Dirs use (".", "../../../support");
package Compiler is
for Switches ("Ada") use ("-g", "-gnateE");
for Switches ("s-memory.adb") use ("-gnatg") & Compiler'Switches ("Ada");
end Compiler;
package Binder is
for Switches ("Ada") use ("-E");
end Binder;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/strings/basics/s-memory.adb 0000644 0001750 0001750 00000012210 13661715457 024550 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Copied from System.Memory, but counts the number of times we do
-- malloc and realloc.
pragma Compiler_Unit_Warning;
with Ada.Exceptions;
with System.Soft_Links;
with System.Parameters;
with System.CRTL;
with Memory;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
function c_malloc (Size : System.CRTL.size_t) return System.Address
renames System.CRTL.malloc;
procedure c_free (Ptr : System.Address)
renames System.CRTL.free;
function c_realloc
(Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
renames System.CRTL.realloc;
-----------
-- Alloc --
-----------
function Alloc (Size : size_t) return System.Address is
Result : System.Address;
Actual_Size : size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
-- Change size from zero to non-zero. We still want a proper pointer
-- for the zero case because pointers to zero length objects have to
-- be distinct, but we can't just go ahead and allocate zero bytes,
-- since some malloc's return zero for a zero argument.
if Size = 0 then
Actual_Size := 1;
end if;
if Parameters.No_Abort then
Result := c_malloc (System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_malloc (System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
Standard.Memory.Allocs := Standard.Memory.Allocs + 1;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc;
----------
-- Free --
----------
procedure Free (Ptr : System.Address) is
begin
if Parameters.No_Abort then
c_free (Ptr);
else
Abort_Defer.all;
c_free (Ptr);
Abort_Undefer.all;
end if;
end Free;
-------------
-- Realloc --
-------------
function Realloc
(Ptr : System.Address;
Size : size_t)
return System.Address
is
Result : System.Address;
Actual_Size : constant size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Parameters.No_Abort then
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
Standard.Memory.Reallocs := Standard.Memory.Reallocs + 1;
return Result;
end Realloc;
end System.Memory;
gnatcoll-core-21.0.0/testsuite/tests/pools/ 0000755 0001750 0001750 00000000000 13661715457 020533 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/pools/test.adb 0000644 0001750 0001750 00000006146 13661715457 022171 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- --
-- G N A T C O L L --
-- --
-- Copyright (C) 2006-2019, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with GNATCOLL.Pools;
with GNATCOLL.Traces;
with Test_Assert;
function Test return Integer is
package A renames Test_Assert;
function Factory (Param : Integer) return Integer;
-- Simple integer factory
type Resource_Set is new Integer range 1 .. 1;
package Int_Pools is new GNATCOLL.Pools
(Element_Type => Integer,
Factory_Param => Integer,
Resource_Set => Resource_Set,
Factory => Factory);
Val2, Val3 : Int_Pools.Resource;
-------------
-- Factory --
-------------
Last_Id : Natural := 0;
function Factory (Param : Integer) return Integer is
pragma Unreferenced (Param);
begin
Last_Id := Last_Id + 1;
return Last_Id;
end Factory;
begin
GNATCOLL.Traces.Parse_Config_File;
Int_Pools.Set_Factory (1, Max_Elements => 2);
declare
Val1 : Int_Pools.Resource;
begin
Int_Pools.Get (Val1);
A.Assert (Val1.Element.all, 1, "element from pool");
Int_Pools.Get (Val2);
A.Assert (Val2.Element.all, 2, "element from pool");
-- Now Val1 goes out of scope and we release the resource
end;
Int_Pools.Get (Val3);
A.Assert (Val3.Element.all, 1, "element from pool");
-- The following would Deadlock
-- Pool.Get (Val2);
Int_Pools.Free;
GNATCOLL.Traces.Finalize;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/pools/test.yaml 0000644 0001750 0001750 00000000054 13661715457 022375 0 ustar nicolas nicolas description: Basic test for GNATCOLL.Pools.
gnatcoll-core-21.0.0/testsuite/tests/string_builders/ 0000755 0001750 0001750 00000000000 13661715457 022576 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/string_builders/test.adb 0000644 0001750 0001750 00000007456 13661715457 024241 0 ustar nicolas nicolas with GNATCOLL.String_Builders;
with Test_Assert;
with Ada.Text_IO;
function Test return Integer is
package SB renames GNATCOLL.String_Builders;
package A renames Test_Assert;
package IO renames Ada.Text_IO;
function C_Len (Str : SB.CString) return Integer
with Import, Convention => C, External_Name => "c_strlen";
begin
IO.Put_Line ("String_Builder tests");
declare
S : SB.String_Builder;
S_Size : constant Integer := SB.String_Builder'Size / 8;
S_Object_Size : constant Integer := SB.String_Builder'Object_Size / 8;
Short_String : constant String := "short string";
Long_String : constant String := "lonnnnnnnnnnnnnnnnnnnnnnnng string";
Dummy_C : Character;
begin
IO.Put_Line ("String_Builder size:" & S_Size'Img);
IO.Put_Line ("String_Builder object size:" & S_Object_Size'Img);
pragma Warnings (Off, """S"" may be referenced before it has a value");
A.Assert (SB.Length (S) = 0);
A.Assert (SB.As_String (S) = "");
A.Assert (C_Len (SB.As_CString (S)) = 0);
pragma Warnings (On, """S"" may be referenced before it has a value");
SB.Append (S, Short_String);
SB.Append (S, 'A');
SB.Append (S, "");
A.Assert (C_Len (SB.As_CString (S)) = Short_String'Length + 1);
SB.Append (S, Long_String);
SB.Append (S, 'B');
SB.Append (S, Long_String);
SB.Append (S, Long_String);
A.Assert
(SB.As_String (S),
Short_String & 'A' & Long_String & 'B' & Long_String & Long_String);
A.Assert (SB.Element (S, 7) = 's');
A.Assert (SB.Length (S) = C_Len (SB.As_CString (S)));
SB.Set (S, "hello");
A.Assert (SB.As_String (S), "hello");
A.Assert (SB.Element (S, 5) = 'o');
A.Assert (SB.Length (S) = C_Len (SB.As_CString (S)));
begin
Dummy_C := SB.Element (S, 6);
A.Assert (False, "no exception");
exception
when Constraint_Error =>
A.Assert (True);
when others =>
A.Assert (False, "wrong exception");
end;
SB.Deallocate (S);
end;
IO.Put_Line ("Static_String_Builder tests");
declare
S : SB.Static_String_Builder (30 + 1);
Short_String : constant String := "0123456789";
Dummy_C : Character;
S1 : SB.Static_String_Builder (1);
begin
pragma Warnings (Off, """S"" may be referenced before it has a value");
A.Assert (SB.Length (S) = 0);
A.Assert (SB.As_String (S), "");
pragma Warnings (On, """S"" may be referenced before it has a value");
SB.Append (S, Short_String);
SB.Append (S, Short_String);
SB.Append (S, "");
SB.Append (S, Short_String);
A.Assert (SB.Length (S) = 30);
A.Assert (SB.As_String (S), Short_String & Short_String & Short_String);
SB.Set (S, "a");
SB.Append (S, 'A');
A.Assert (SB.Length (S) = 2);
A.Assert (SB.As_String (S) = "aA");
A.Assert (SB.Element (S, 2) = 'A');
begin
Dummy_C := SB.Element (S, 3);
A.Assert (False, "no exception");
exception
when Constraint_Error =>
A.Assert (True);
when others =>
A.Assert (False, "wrong exception");
end;
begin
SB.Append (S1, 'a');
A.Assert (False, "no exception");
exception
when Constraint_Error =>
A.Assert (True);
when others =>
A.Assert (False, "wrong exception");
end;
begin
SB.Append (S1, "A");
A.Assert (False, "no exception");
exception
when Constraint_Error =>
A.Assert (True);
when others =>
A.Assert (False, "wrong exception");
end;
A.Assert (C_Len (SB.As_CString (S1)) = 0);
end;
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/string_builders/test_c.c 0000644 0001750 0001750 00000000120 13661715457 024214 0 ustar nicolas nicolas #include
int c_strlen (char *message) {
return strlen (message);
}
gnatcoll-core-21.0.0/testsuite/tests/string_builders/test.yaml 0000644 0001750 0001750 00000000040 13661715457 024433 0 ustar nicolas nicolas title: GNATCOLL.String_Builders
gnatcoll-core-21.0.0/testsuite/tests/email/ 0000755 0001750 0001750 00000000000 13661715457 020466 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/email/email_data/ 0000755 0001750 0001750 00000000000 13661715457 022546 5 ustar nicolas nicolas gnatcoll-core-21.0.0/testsuite/tests/email/email_data/test.adb 0000644 0001750 0001750 00000005636 13661715457 024207 0 ustar nicolas nicolas ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2006-2019, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Calendar;
with Test_Assert;
with GNATCOLL.Email.Mailboxes;
with GNATCOLL.Email.Utils;
use GNATCOLL.Email,
GNATCOLL.Email.Mailboxes,
GNATCOLL.Email.Utils;
with GNATCOLL.VFS; use GNATCOLL.VFS;
function Test return Integer is
package Cal renames Ada.Calendar;
package A renames Test_Assert;
Count : Natural := 0;
procedure Parse_File (Filename : String);
-- Parse file as mailbox
procedure Parse_File (Filename : String) is
Box : Mbox;
Msg : Message;
Addr : Address_Set.Set;
T : Cal.Time;
pragma Unreferenced (Addr, T);
begin
Open (Box, Filename => Create (+Filename));
declare
Curs : GNATCOLL.Email.Mailboxes.Cursor'Class := First (Box);
begin
while Has_Element (Curs) loop
Get_Message (Curs, Box, Msg);
if Msg /= Null_Message then
Addr := Get_Recipients (Msg);
T := Date_From_Envelope (Msg);
end if;
Next (Curs, Box);
Count := Count + 1;
end loop;
end;
end Parse_File;
begin
Parse_File ("tea_party.mbx");
A.Assert (Count, 95, "expected number of messages");
return A.Report;
end Test;
gnatcoll-core-21.0.0/testsuite/tests/email/email_data/test.yaml 0000644 0001750 0001750 00000000160 13661715457 024406 0 ustar nicolas nicolas description: email data and parse test.
data:
- "*.mbx"
# The test set is derived from mailutils testsuite
gnatcoll-core-21.0.0/testsuite/tests/email/email_data/tea_party.mbx 0000644 0001750 0001750 00000127032 13661715457 025253 0 ustar nicolas nicolas From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3301
for alice@wonder.land; Mon, 29 Jul 2002 22:00:06 +0100
Date: Mon, 29 Jul 2002 22:00:01 +0100
From: March Hare
Message-Id: <200207292200.3301@wonder.land>
To: Alice
Subject: Invitation
X-IMAPbase: 0 1
X-Envelope-Date: Mon Jul 29 22:00:08 2002
X-Envelope-Sender: hare@wonder.land
Have some wine
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3302
for hare@wonder.land; Mon, 29 Jul 2002 22:00:07 +0100
Date: Mon, 29 Jul 2002 22:00:02 +0100
From: Alice
Message-Id: <200207292200.3302@wonder.land>
To: March Hare
Subject: Re: Invitation
X-Envelope-Date: Mon Jul 29 22:00:09 2002
X-Envelope-Sender: alice@wonder.land
I don't see any wine
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3303
for alice@wonder.land; Mon, 29 Jul 2002 22:00:08 +0100
Date: Mon, 29 Jul 2002 22:00:03 +0100
From: March Hare
Message-Id: <200207292200.3303@wonder.land>
To: Alice
Subject: Re: Invitation
X-Envelope-Date: Mon Jul 29 22:00:10 2002
X-Envelope-Sender: hare@wonder.land
There isn't any
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3304
for hare@wonder.land; Mon, 29 Jul 2002 22:00:09 +0100
Date: Mon, 29 Jul 2002 22:00:04 +0100
From: Alice
Message-Id: <200207292200.3304@wonder.land>
To: March Hare
Subject: Re: Invitation
X-Envelope-Date: Mon Jul 29 22:00:11 2002
X-Envelope-Sender: alice@wonder.land
Then it wasn't very civil of you to offer it
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3305
for alice@wonder.land; Mon, 29 Jul 2002 22:00:10 +0100
Date: Mon, 29 Jul 2002 22:00:05 +0100
From: March Hare
Message-Id: <200207292200.3305@wonder.land>
To: Alice
Subject: Re: Invitation
X-Envelope-Date: Mon Jul 29 22:00:12 2002
X-Envelope-Sender: hare@wonder.land
It wasn't very civil of you to sit down without being invited
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3306
for hare@wonder.land; Mon, 29 Jul 2002 22:00:11 +0100
Date: Mon, 29 Jul 2002 22:00:06 +0100
From: Alice
Message-Id: <200207292200.3306@wonder.land>
To: March Hare
Subject: Re: Invitation
X-Envelope-Date: Mon Jul 29 22:00:13 2002
X-Envelope-Sender: alice@wonder.land
I didn't know it was YOUR table, it's laid for a
great many more than three.
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3307
for alice@wonder.land; Mon, 29 Jul 2002 22:00:12 +0100
Date: Mon, 29 Jul 2002 22:00:07 +0100
From: March Hare
Message-Id: <200207292200.3307@wonder.land>
To: Alice
Subject: Personal remark
X-Envelope-Date: Mon Jul 29 22:00:14 2002
X-Envelope-Sender: hare@wonder.land
Your hair wants cutting
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3308
for hare@wonder.land; Mon, 29 Jul 2002 22:00:13 +0100
Date: Mon, 29 Jul 2002 22:00:08 +0100
From: Alice
Message-Id: <200207292200.3308@wonder.land>
To: March Hare
Subject: Re: Personal remark
X-Envelope-Date: Mon Jul 29 22:00:15 2002
X-Envelope-Sender: alice@wonder.land
You should learn not to make personal remarks, it's very rude.
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3309
for alice@wonder.land; Mon, 29 Jul 2002 22:00:14 +0100
Date: Mon, 29 Jul 2002 22:00:09 +0100
From: March Hare
Message-Id: <200207292200.3309@wonder.land>
To: Alice
Subject: Riddle (was Re: Personal remark)
X-Envelope-Date: Mon Jul 29 22:00:16 2002
X-Envelope-Sender: hare@wonder.land
Why is a raven like a writing-desk?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3310
for hare@wonder.land; Mon, 29 Jul 2002 22:00:15 +0100
Date: Mon, 29 Jul 2002 22:00:10 +0100
From: Alice
Message-Id: <200207292200.3310@wonder.land>
To: March Hare
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:17 2002
X-Envelope-Sender: alice@wonder.land
I believe I can guess that
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3311
for alice@wonder.land; Mon, 29 Jul 2002 22:00:16 +0100
Date: Mon, 29 Jul 2002 22:00:11 +0100
From: March Hare
Message-Id: <200207292200.3311@wonder.land>
To: Alice
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:18 2002
X-Envelope-Sender: hare@wonder.land
Do you mean that you think you can find out the answer to it?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3312
for hare@wonder.land; Mon, 29 Jul 2002 22:00:17 +0100
Date: Mon, 29 Jul 2002 22:00:12 +0100
From: Alice
Message-Id: <200207292200.3312@wonder.land>
To: March Hare
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:19 2002
X-Envelope-Sender: alice@wonder.land
Exactly so
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3313
for alice@wonder.land; Mon, 29 Jul 2002 22:00:18 +0100
Date: Mon, 29 Jul 2002 22:00:13 +0100
From: March Hare
Message-Id: <200207292200.3313@wonder.land>
To: Alice
Subject: Be specific (was Re: Riddle)
X-Envelope-Date: Mon Jul 29 22:00:20 2002
X-Envelope-Sender: hare@wonder.land
Then you should say what you mean
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3314
for hare@wonder.land; Mon, 29 Jul 2002 22:00:19 +0100
Date: Mon, 29 Jul 2002 22:00:14 +0100
From: Alice
Message-Id: <200207292200.3314@wonder.land>
To: March Hare
Subject: Re: Be specific
X-Envelope-Date: Mon Jul 29 22:00:21 2002
X-Envelope-Sender: alice@wonder.land
I do, at least--at least I mean what
I say--that's the same thing, you know.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3315
for alice@wonder.land; Mon, 29 Jul 2002 22:00:20 +0100
Date: Mon, 29 Jul 2002 22:00:15 +0100
From: Hatter
Message-Id: <200207292200.3315@wonder.land>
To: Alice
Subject: Re: Be specific
X-Envelope-Date: Mon Jul 29 22:00:22 2002
X-Envelope-Sender: hatter@wonder.land
Not the same thing a bit! You might just
as well say that "I see what I eat" is the same thing as "I eat
what I see"!
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3316
for alice@wonder.land; Mon, 29 Jul 2002 22:00:21 +0100
Date: Mon, 29 Jul 2002 22:00:16 +0100
From: March Hare
Message-Id: <200207292200.3316@wonder.land>
To: Alice
Subject: Re: Be specific
X-Envelope-Date: Mon Jul 29 22:00:23 2002
X-Envelope-Sender: hare@wonder.land
You might just as well say, that "I
like what I get" is the same thing as "I get what I like"!
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3317
for alice@wonder.land; Mon, 29 Jul 2002 22:00:22 +0100
Date: Mon, 29 Jul 2002 22:00:17 +0100
From: Dormouse
Message-Id: <200207292200.3317@wonder.land>
To: Alice
Subject: Re: Be specific
X-Envelope-Date: Mon Jul 29 22:00:24 2002
X-Envelope-Sender: dormouse@wonder.land
You might just as well say, who seemed to
be talking in his sleep, `that "I breathe when I sleep" is the
same thing as "I sleep when I breathe"!
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3318
for dormouse@wonder.land; Mon, 29 Jul 2002 22:00:23 +0100
Date: Mon, 29 Jul 2002 22:00:18 +0100
From: Hatter
Message-Id: <200207292200.3318@wonder.land>
To: Dormouse
Subject: Re: Be specific
X-Envelope-Date: Mon Jul 29 22:00:25 2002
X-Envelope-Sender: hatter@wonder.land
It IS the same thing with you
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3319
for alice@wonder.land; Mon, 29 Jul 2002 22:00:24 +0100
Date: Mon, 29 Jul 2002 22:00:19 +0100
From: Hatter
Message-Id: <200207292200.3319@wonder.land>
To: Alice
Subject: Watch
X-Envelope-Date: Mon Jul 29 22:00:26 2002
X-Envelope-Sender: hatter@wonder.land
What day of the month is it?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3320
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:25 +0100
Date: Mon, 29 Jul 2002 22:00:20 +0100
From: Alice
Message-Id: <200207292200.3320@wonder.land>
To: Hatter
Subject: Re: Watch
X-Envelope-Date: Mon Jul 29 22:00:27 2002
X-Envelope-Sender: alice@wonder.land
The fourth.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3321
for hare@wonder.land; Mon, 29 Jul 2002 22:00:26 +0100
Date: Mon, 29 Jul 2002 22:00:21 +0100
From: Hatter
Message-Id: <200207292200.3321@wonder.land>
To: March Hare
Subject: Re: Watch
X-Envelope-Date: Mon Jul 29 22:00:28 2002
X-Envelope-Sender: hatter@wonder.land
Two days wrong! I told you butter wouldn't suit the works!
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3322
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:27 +0100
Date: Mon, 29 Jul 2002 22:00:22 +0100
From: March Hare
Message-Id: <200207292200.3322@wonder.land>
To: Hatter
Subject: Re: Watch
X-Envelope-Date: Mon Jul 29 22:00:29 2002
X-Envelope-Sender: hare@wonder.land
It was the BEST butter
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3323
for hare@wonder.land; Mon, 29 Jul 2002 22:00:28 +0100
Date: Mon, 29 Jul 2002 22:00:23 +0100
From: Hatter
Message-Id: <200207292200.3323@wonder.land>
To: March Hare
Subject: Re: Watch
X-Envelope-Date: Mon Jul 29 22:00:30 2002
X-Envelope-Sender: hatter@wonder.land
Yes, but some crumbs must have got in as well,
you shouldn't have put it in with the bread-knife.
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3324
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:29 +0100
Date: Mon, 29 Jul 2002 22:00:24 +0100
From: March Hare
Message-Id: <200207292200.3324@wonder.land>
To: Hatter
Subject: Re: Watch
X-Envelope-Date: Mon Jul 29 22:00:31 2002
X-Envelope-Sender: hare@wonder.land
It was the BEST butter, you know.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3325
for tea.party@wonder.land; Mon, 29 Jul 2002 22:00:30 +0100
Date: Mon, 29 Jul 2002 22:00:25 +0100
From: Alice
Message-Id: <200207292200.3325@wonder.land>
To: Mad Tea Party
Subject: Funny watch (was Re: Watch)
X-Envelope-Date: Mon Jul 29 22:00:32 2002
X-Envelope-Sender: alice@wonder.land
What a funny watch! It tells the day of the
month, and doesn't tell what o'clock it is!
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3326
for alice@wonder.land; Mon, 29 Jul 2002 22:00:31 +0100
Date: Mon, 29 Jul 2002 22:00:26 +0100
From: Hatter
Message-Id: <200207292200.3326@wonder.land>
To: Alice
Subject: Re: Funny watch
X-Envelope-Date: Mon Jul 29 22:00:33 2002
X-Envelope-Sender: hatter@wonder.land
Why should it? Does YOUR watch tell you what year it is?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3327
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:32 +0100
Date: Mon, 29 Jul 2002 22:00:27 +0100
From: Alice
Message-Id: <200207292200.3327@wonder.land>
To: Hatter
Subject: Re: Funny watch
X-Envelope-Date: Mon Jul 29 22:00:34 2002
X-Envelope-Sender: alice@wonder.land
Of course not, but that's because it stays the same year for such
a long time together.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3328
for alice@wonder.land; Mon, 29 Jul 2002 22:00:33 +0100
Date: Mon, 29 Jul 2002 22:00:28 +0100
From: Hatter
Message-Id: <200207292200.3328@wonder.land>
To: Alice
Subject: Re: Funny watch
X-Envelope-Date: Mon Jul 29 22:00:35 2002
X-Envelope-Sender: hatter@wonder.land
Which is just the case with MINE
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3329
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:34 +0100
Date: Mon, 29 Jul 2002 22:00:29 +0100
From: Alice
Message-Id: <200207292200.3329@wonder.land>
To: Hatter
Subject: Re: Funny watch
X-Envelope-Date: Mon Jul 29 22:00:36 2002
X-Envelope-Sender: alice@wonder.land
I don't quite understand you
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3330
for tea.party@wonder.land; Mon, 29 Jul 2002 22:00:35 +0100
Date: Mon, 29 Jul 2002 22:00:30 +0100
From: Hatter
Message-Id: <200207292200.3330@wonder.land>
To: Mad Tea Party
Subject: Remark
X-Envelope-Date: Mon Jul 29 22:00:37 2002
X-Envelope-Sender: hatter@wonder.land
The Dormouse is asleep again
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3331
for nobody@wonder.land; Mon, 29 Jul 2002 22:00:36 +0100
Date: Mon, 29 Jul 2002 22:00:31 +0100
From: Dormouse
Message-Id: <200207292200.3331@wonder.land>
To: Nobody at all
Subject: Re: Remark
X-Envelope-Date: Mon Jul 29 22:00:38 2002
X-Envelope-Sender: dormouse@wonder.land
Of course, of course; just what I was going to
remark myself.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3332
for alice@wonder.land; Mon, 29 Jul 2002 22:00:37 +0100
Date: Mon, 29 Jul 2002 22:00:32 +0100
From: Hatter
Message-Id: <200207292200.3332@wonder.land>
To: Alice
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:39 2002
X-Envelope-Sender: hatter@wonder.land
Have you guessed the riddle yet?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3333
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:38 +0100
Date: Mon, 29 Jul 2002 22:00:33 +0100
From: Alice
Message-Id: <200207292200.3333@wonder.land>
To: Hatter
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:40 2002
X-Envelope-Sender: alice@wonder.land
No, I give it up, what's the answer?
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3334
for alice@wonder.land; Mon, 29 Jul 2002 22:00:39 +0100
Date: Mon, 29 Jul 2002 22:00:34 +0100
From: Hatter
Message-Id: <200207292200.3334@wonder.land>
To: Alice
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:41 2002
X-Envelope-Sender: hatter@wonder.land
I haven't the slightest idea
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3335
for alice@wonder.land; Mon, 29 Jul 2002 22:00:40 +0100
Date: Mon, 29 Jul 2002 22:00:35 +0100
From: March Hare
Message-Id: <200207292200.3335@wonder.land>
To: Alice
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:42 2002
X-Envelope-Sender: hare@wonder.land
Nor I
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3336
for tea.party@wonder.land; Mon, 29 Jul 2002 22:00:41 +0100
Date: Mon, 29 Jul 2002 22:00:36 +0100
From: Alice
Message-Id: <200207292200.3336@wonder.land>
To: Mad Tea Party
Subject: Re: Riddle
X-Envelope-Date: Mon Jul 29 22:00:43 2002
X-Envelope-Sender: alice@wonder.land
I think you might do something better with the time, than waste it in
asking riddles that have no answers.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3337
for alice@wonder.land; Mon, 29 Jul 2002 22:00:42 +0100
Date: Mon, 29 Jul 2002 22:00:37 +0100
From: Hatter
Message-Id: <200207292200.3337@wonder.land>
To: Alice
Subject: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:44 2002
X-Envelope-Sender: hatter@wonder.land
If you knew Time as well as I do, you
wouldn't talk about wasting IT. It's HIM.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3338
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:43 +0100
Date: Mon, 29 Jul 2002 22:00:38 +0100
From: Alice
Message-Id: <200207292200.3338@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:45 2002
X-Envelope-Sender: alice@wonder.land
I don't know what you mean
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3339
for alice@wonder.land; Mon, 29 Jul 2002 22:00:44 +0100
Date: Mon, 29 Jul 2002 22:00:39 +0100
From: Hatter
Message-Id: <200207292200.3339@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:46 2002
X-Envelope-Sender: hatter@wonder.land
Of course you don't! I dare say you never even spoke to Time!
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3340
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:45 +0100
Date: Mon, 29 Jul 2002 22:00:40 +0100
From: Alice
Message-Id: <200207292200.3340@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:47 2002
X-Envelope-Sender: alice@wonder.land
Perhaps not, but I know I have to beat time when I learn music.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3341
for alice@wonder.land; Mon, 29 Jul 2002 22:00:46 +0100
Date: Mon, 29 Jul 2002 22:00:41 +0100
From: Hatter
Message-Id: <200207292200.3341@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:48 2002
X-Envelope-Sender: hatter@wonder.land
Ah! that accounts for it. He won't stand
beating. Now, if you only kept on good terms with him, he'd do
almost anything you liked with the clock. For instance, suppose
it were nine o'clock in the morning, just time to begin lessons:
you'd only have to whisper a hint to Time, and round goes the
clock in a twinkling! Half-past one, time for dinner!
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3342
for hare@wonder.land; Mon, 29 Jul 2002 22:00:47 +0100
Date: Mon, 29 Jul 2002 22:00:42 +0100
From: March Hare
Message-Id: <200207292200.3342@wonder.land>
To: March Hare
Subject: Thought apart Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:49 2002
X-Envelope-Sender: hare@wonder.land
I only wish it was
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3343
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:48 +0100
Date: Mon, 29 Jul 2002 22:00:43 +0100
From: Alice
Message-Id: <200207292200.3343@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:50 2002
X-Envelope-Sender: alice@wonder.land
That would be grand, certainly, but then--I shouldn't be hungry for it,
you know.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3344
for alice@wonder.land; Mon, 29 Jul 2002 22:00:49 +0100
Date: Mon, 29 Jul 2002 22:00:44 +0100
From: Hatter
Message-Id: <200207292200.3344@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:51 2002
X-Envelope-Sender: hatter@wonder.land
Not at first, perhaps, but you could keep
it to half-past one as long as you liked.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3345
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:50 +0100
Date: Mon, 29 Jul 2002 22:00:45 +0100
From: Alice
Message-Id: <200207292200.3345@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:52 2002
X-Envelope-Sender: alice@wonder.land
Is that the way YOU manage?
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3346
for alice@wonder.land; Mon, 29 Jul 2002 22:00:51 +0100
Date: Mon, 29 Jul 2002 22:00:46 +0100
From: Hatter
Message-Id: <200207292200.3346@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:53 2002
X-Envelope-Sender: hatter@wonder.land
Not I! We quarrelled last March--just before HE went mad, you know--
it was at the great concert given by the Queen of Hearts, and I had
to sing
"Twinkle, twinkle, little bat!
How I wonder what you're at!"
You know the song, perhaps?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3347
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:52 +0100
Date: Mon, 29 Jul 2002 22:00:47 +0100
From: Alice
Message-Id: <200207292200.3347@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:54 2002
X-Envelope-Sender: alice@wonder.land
I've heard something like it
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3348
for alice@wonder.land; Mon, 29 Jul 2002 22:00:53 +0100
Date: Mon, 29 Jul 2002 22:00:48 +0100
From: Hatter
Message-Id: <200207292200.3348@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:55 2002
X-Envelope-Sender: hatter@wonder.land
It goes on, you know in this way:--
"Up above the world you fly,
Like a tea-tray in the sky.
Twinkle, twinkle--"'
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3349
for nobody@wonder.land; Mon, 29 Jul 2002 22:00:54 +0100
Date: Mon, 29 Jul 2002 22:00:49 +0100
From: Dormouse
Message-Id: <200207292200.3349@wonder.land>
To: Nobody at all
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:56 2002
X-Envelope-Sender: dormouse@wonder.land
Twinkle, twinkle, twinkle, twinkle...
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3350
for alice@wonder.land; Mon, 29 Jul 2002 22:00:55 +0100
Date: Mon, 29 Jul 2002 22:00:50 +0100
From: Hatter
Message-Id: <200207292200.3350@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:57 2002
X-Envelope-Sender: hatter@wonder.land
Well, I'd hardly finished the first verse, when the Queen jumped up
and bawled out, "He's murdering the time! Off with his head!"
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3351
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:56 +0100
Date: Mon, 29 Jul 2002 22:00:51 +0100
From: Alice
Message-Id: <200207292200.3351@wonder.land>
To: Hatter
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:58 2002
X-Envelope-Sender: alice@wonder.land
How dreadfully savage!
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3352
for alice@wonder.land; Mon, 29 Jul 2002 22:00:57 +0100
Date: Mon, 29 Jul 2002 22:00:52 +0100
From: Hatter
Message-Id: <200207292200.3352@wonder.land>
To: Alice
Subject: Re: Discussing Time
X-Envelope-Date: Mon Jul 29 22:00:59 2002
X-Envelope-Sender: hatter@wonder.land
And ever since that, he won't do a thing I ask! It's always six o'clock now.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3353
for hatter@wonder.land; Mon, 29 Jul 2002 22:00:58 +0100
Date: Mon, 29 Jul 2002 22:00:53 +0100
From: Alice
Message-Id: <200207292200.3353@wonder.land>
To: Hatter
Subject: A guess (was Re: Discussing Time)
X-Envelope-Date: Mon Jul 29 22:01:00 2002
X-Envelope-Sender: alice@wonder.land
Is that the reason so
many tea-things are put out here?
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3354
for alice@wonder.land; Mon, 29 Jul 2002 22:00:59 +0100
Date: Mon, 29 Jul 2002 22:00:54 +0100
From: Hatter
Message-Id: <200207292200.3354@wonder.land>
To: Alice
Subject: Re: A guess
X-Envelope-Date: Mon Jul 29 22:01:01 2002
X-Envelope-Sender: hatter@wonder.land
Yes, that's it. It's always
tea-time, and we've no time to wash the things between whiles.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3355
for hatter@wonder.land; Mon, 29 Jul 2002 22:01:00 +0100
Date: Mon, 29 Jul 2002 22:00:55 +0100
From: Alice
Message-Id: <200207292200.3355@wonder.land>
To: Hatter
Subject: Re: A guess
X-Envelope-Date: Mon Jul 29 22:01:02 2002
X-Envelope-Sender: alice@wonder.land
Then you keep moving round, I suppose?
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3356
for alice@wonder.land; Mon, 29 Jul 2002 22:01:01 +0100
Date: Mon, 29 Jul 2002 22:00:56 +0100
From: Hatter
Message-Id: <200207292200.3356@wonder.land>
To: Alice
Subject: Re: A guess
X-Envelope-Date: Mon Jul 29 22:01:03 2002
X-Envelope-Sender: hatter@wonder.land
Exactly so, as the things get used up.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3357
for hatter@wonder.land; Mon, 29 Jul 2002 22:01:02 +0100
Date: Mon, 29 Jul 2002 22:00:57 +0100
From: Alice
Message-Id: <200207292200.3357@wonder.land>
To: Hatter
Subject: Re: A guess
X-Envelope-Date: Mon Jul 29 22:01:04 2002
X-Envelope-Sender: alice@wonder.land
But what happens when you come to the beginning again?
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3358
for tea.party@wonder.land; Mon, 29 Jul 2002 22:01:03 +0100
Date: Mon, 29 Jul 2002 22:00:58 +0100
From: March Hare
Message-Id: <200207292200.3358@wonder.land>
To: Mad Tea Party
Subject: Request for a story (was Re: A guess)
X-Envelope-Date: Mon Jul 29 22:01:05 2002
X-Envelope-Sender: hare@wonder.land
Suppose we change the subject, I'm getting tired of this.
I vote the young lady tells us a story.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3359
for hare@wonder.land; Mon, 29 Jul 2002 22:01:04 +0100
Date: Mon, 29 Jul 2002 22:00:59 +0100
From: Alice
Message-Id: <200207292200.3359@wonder.land>
To: March Hare
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:06 2002
X-Envelope-Sender: alice@wonder.land
I'm afraid I don't know one
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3360
for tea.party@wonder.land; Mon, 29 Jul 2002 22:01:05 +0100
Date: Mon, 29 Jul 2002 22:01:00 +0100
From: Hatter
Message-Id: <200207292201.3360@wonder.land>
To: Mad Tea Party
Cc: Dormouse
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:07 2002
X-Envelope-Sender: hatter@wonder.land
Then the Dormouse shall!
Wake up, Dormouse!
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3361
for tea.party@wonder.land; Mon, 29 Jul 2002 22:01:06 +0100
Date: Mon, 29 Jul 2002 22:01:01 +0100
From: Dormouse
Message-Id: <200207292201.3361@wonder.land>
To: Mad Tea Party
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:08 2002
X-Envelope-Sender: dormouse@wonder.land
I wasn't asleep. I heard every word you fellows
were saying.
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3362
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:07 +0100
Date: Mon, 29 Jul 2002 22:01:02 +0100
From: March Hare
Message-Id: <200207292201.3362@wonder.land>
To: Dormouse
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:09 2002
X-Envelope-Sender: hare@wonder.land
Tell us a story!
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3363
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:08 +0100
Date: Mon, 29 Jul 2002 22:01:03 +0100
From: Alice
Message-Id: <200207292201.3363@wonder.land>
To: Dormouse
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:10 2002
X-Envelope-Sender: alice@wonder.land
Yes, please do!
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3364
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:09 +0100
Date: Mon, 29 Jul 2002 22:01:04 +0100
From: Hatter
Message-Id: <200207292201.3364@wonder.land>
To: Dormouse
Subject: Re: Request for a story
X-Envelope-Date: Mon Jul 29 22:01:11 2002
X-Envelope-Sender: hatter@wonder.land
And be quick about it, or you'll be asleep
again before it's done.
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3365
for tea.party@wonder.land; Mon, 29 Jul 2002 22:01:10 +0100
Date: Mon, 29 Jul 2002 22:01:05 +0100
From: Dormouse
Message-Id: <200207292201.3365@wonder.land>
To: Mad Tea Party
Subject: Story (was Re: Request for a story)
X-Envelope-Date: Mon Jul 29 22:01:12 2002
X-Envelope-Sender: dormouse@wonder.land
Once upon a time there were three little sisters, and their names
were Elsie,
Lacie, and Tillie; and they lived at the bottom of a well--
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3366
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:11 +0100
Date: Mon, 29 Jul 2002 22:01:06 +0100
From: Alice
Message-Id: <200207292201.3366@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:13 2002
X-Envelope-Sender: alice@wonder.land
What did they live on?
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3367
for alice@wonder.land; Mon, 29 Jul 2002 22:01:12 +0100
Date: Mon, 29 Jul 2002 22:01:07 +0100
From: Dormouse
Message-Id: <200207292201.3367@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:14 2002
X-Envelope-Sender: dormouse@wonder.land
They lived on treacle
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3368
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:13 +0100
Date: Mon, 29 Jul 2002 22:01:08 +0100
From: Alice
Message-Id: <200207292201.3368@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:15 2002
X-Envelope-Sender: alice@wonder.land
They couldn't have done that, you know, they'd have been ill
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3369
for alice@wonder.land; Mon, 29 Jul 2002 22:01:14 +0100
Date: Mon, 29 Jul 2002 22:01:09 +0100
From: Dormouse
Message-Id: <200207292201.3369@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:16 2002
X-Envelope-Sender: dormouse@wonder.land
So they were, VERY ill.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3370
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:15 +0100
Date: Mon, 29 Jul 2002 22:01:10 +0100
From: Alice
Message-Id: <200207292201.3370@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:17 2002
X-Envelope-Sender: alice@wonder.land
But why did they live at the bottom of a well?
From March Hare
Received: (from hare@wonder.land)
by wonder.land id 3371
for alice@wonder.land; Mon, 29 Jul 2002 22:01:16 +0100
Date: Mon, 29 Jul 2002 22:01:11 +0100
From: March Hare
Message-Id: <200207292201.3371@wonder.land>
To: Alice
Subject: Remark
X-Envelope-Date: Mon Jul 29 22:01:18 2002
X-Envelope-Sender: hare@wonder.land
Take some more tea
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3372
for hare@wonder.land; Mon, 29 Jul 2002 22:01:17 +0100
Date: Mon, 29 Jul 2002 22:01:12 +0100
From: Alice
Message-Id: <200207292201.3372@wonder.land>
To: March Hare
Subject: Re: Remark
X-Envelope-Date: Mon Jul 29 22:01:19 2002
X-Envelope-Sender: alice@wonder.land
I've had nothing yet, so
I can't take more.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3373
for alice@wonder.land; Mon, 29 Jul 2002 22:01:18 +0100
Date: Mon, 29 Jul 2002 22:01:13 +0100
From: Hatter
Message-Id: <200207292201.3373@wonder.land>
To: Alice
Subject: Re: Remark
X-Envelope-Date: Mon Jul 29 22:01:20 2002
X-Envelope-Sender: hatter@wonder.land
You mean you can't take LESS, it's very
easy to take MORE than nothing.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3374
for hatter@wonder.land; Mon, 29 Jul 2002 22:01:19 +0100
Date: Mon, 29 Jul 2002 22:01:14 +0100
From: Alice
Message-Id: <200207292201.3374@wonder.land>
To: Hatter
Subject: Personal remark
X-Envelope-Date: Mon Jul 29 22:01:21 2002
X-Envelope-Sender: alice@wonder.land
Nobody asked YOUR opinion
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3375
for alice@wonder.land; Mon, 29 Jul 2002 22:01:20 +0100
Date: Mon, 29 Jul 2002 22:01:15 +0100
From: Hatter
Message-Id: <200207292201.3375@wonder.land>
To: Alice
Subject: Re: Personal remark
X-Envelope-Date: Mon Jul 29 22:01:22 2002
X-Envelope-Sender: hatter@wonder.land
Who's making personal remarks now?
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3376
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:21 +0100
Date: Mon, 29 Jul 2002 22:01:16 +0100
From: Alice
Message-Id: <200207292201.3376@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:23 2002
X-Envelope-Sender: alice@wonder.land
Why did they live at the
bottom of a well?
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3377
for alice@wonder.land; Mon, 29 Jul 2002 22:01:22 +0100
Date: Mon, 29 Jul 2002 22:01:17 +0100
From: Dormouse
Message-Id: <200207292201.3377@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:24 2002
X-Envelope-Sender: dormouse@wonder.land
It was a treacle-well.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3378
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:23 +0100
Date: Mon, 29 Jul 2002 22:01:18 +0100
From: Alice
Message-Id: <200207292201.3378@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:25 2002
X-Envelope-Sender: alice@wonder.land
There's no such thing!
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3379
for alice@wonder.land; Mon, 29 Jul 2002 22:01:24 +0100
Date: Mon, 29 Jul 2002 22:01:19 +0100
From: Dormouse
Message-Id: <200207292201.3379@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:26 2002
X-Envelope-Sender: dormouse@wonder.land
If you can't be civil, you'd better finish the
story for yourself.
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3380
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:25 +0100
Date: Mon, 29 Jul 2002 22:01:20 +0100
From: Alice
Message-Id: <200207292201.3380@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:27 2002
X-Envelope-Sender: alice@wonder.land
No, please go on! I won't interrupt
again. I dare say there may be ONE.
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3381
for alice@wonder.land; Mon, 29 Jul 2002 22:01:26 +0100
Date: Mon, 29 Jul 2002 22:01:21 +0100
From: Dormouse
Message-Id: <200207292201.3381@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:28 2002
X-Envelope-Sender: dormouse@wonder.land
One, indeed! And so these three little sisters--they
were learning to draw, you know--
From Alice
Received: (from alice@wonder.land)
by wonder.land id 3382
for dormouse@wonder.land; Mon, 29 Jul 2002 22:01:27 +0100
Date: Mon, 29 Jul 2002 22:01:22 +0100
From: Alice
Message-Id: <200207292201.3382@wonder.land>
To: Dormouse
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:29 2002
X-Envelope-Sender: alice@wonder.land
What did they draw?
From Dormouse
Received: (from dormouse@wonder.land)
by wonder.land id 3383
for alice@wonder.land; Mon, 29 Jul 2002 22:01:28 +0100
Date: Mon, 29 Jul 2002 22:01:23 +0100
From: Dormouse
Message-Id: <200207292201.3383@wonder.land>
To: Alice
Subject: Re: Story
X-Envelope-Date: Mon Jul 29 22:01:30 2002
X-Envelope-Sender: dormouse@wonder.land
Treacle.
From Hatter
Received: (from hatter@wonder.land)
by wonder.land id 3384
for tea.party@wonder.land; Mon, 29 Jul 2002 22:01:29 +0100
Date: Mon, 29 Jul 2002 22:01:24 +0100
From: Hatter
Message-Id: <200207292201.3384@wonder.land>
To: Mad Tea Party